[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/04: Add language/wisp, Wisp tests, and SRFI-119 docum
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] 02/04: Add language/wisp, Wisp tests, and SRFI-119 documentation |
|
Date: |
Sat, 1 Jun 2024 05:52:36 -0400 (EDT) |
civodul pushed a commit to branch main
in repository guile.
commit dce65edbaf55ce8ead6c9b100b6f4059b09e0ffc
Author: Arne Babenhauserheide <arne_bab@web.de>
AuthorDate: Mon Mar 11 06:34:52 2024 +0100
Add language/wisp, Wisp tests, and SRFI-119 documentation
* doc/ref/srfi-modules.texi (srfi-119): add node
* module/language/wisp.scm: New file.
* module/language/wisp/spec.scm: New file.
* test-suite/tests/srfi-119.test: New file.
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
---
am/bootstrap.am | 3 +
doc/ref/srfi-modules.texi | 31 ++
module/language/wisp.scm | 776 ++++++++++++++++++++++++++++++
module/language/wisp/spec.scm | 70 +++
test-suite/Makefile.am | 3 +-
test-suite/tests/srfi-119.test | 1040 ++++++++++++++++++++++++++++++++++++++++
6 files changed, 1922 insertions(+), 1 deletion(-)
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 00f677e4f..9e5fca0db 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -396,6 +396,9 @@ SOURCES = \
\
system/syntax.scm \
\
+ language/wisp.scm \
+ language/wisp/spec.scm \
+ \
system/xref.scm \
\
sxml/apply-templates.scm \
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index efb9ccca4..02da3e2f2 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -64,6 +64,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-98:: Accessing environment variables.
* SRFI-105:: Curly-infix expressions.
* SRFI-111:: Boxes.
+* SRFI-119:: Wisp: simpler indentation-sensitive Scheme.
* SRFI-171:: Transducers
@end menu
@@ -5662,6 +5663,35 @@ Return the current contents of @var{box}.
Set the contents of @var{box} to @var{value}.
@end deffn
+@node SRFI-119
+@subsection SRFI-119 Wisp: simpler indentation-sensitive Scheme.
+@cindex SRFI-119
+@cindex wisp
+
+The languages shipped in Guile include SRFI-119, also referred to as
+@dfn{Wisp} (for ``Whitespace to Lisp''), an encoding of Scheme that
+allows replacing parentheses with equivalent indentation and inline
+colons. See
+@uref{http://srfi.schemers.org/srfi-119/srfi-119.html, the specification
+of SRFI-119}. Some examples:
+
+@example
+display "Hello World!" @result{} (display "Hello World!")
+@end example
+
+@example
+define : factorial n @result{} (define (factorial n)
+ if : zero? n @result{} (if (zero? n)
+ . 1 @result{} 1
+ * n : factorial @{n - 1@} @result{} (* n (factorial @{n - 1@}))))
+@end example
+
+To execute a file with Wisp code, select the language and filename
+extension @code{.w} vie @code{guile --language=wisp -x .w}.
+
+In files using Wisp, @xref{SRFI-105} (Curly Infix) is always activated.
+
+
@node SRFI-171
@subsection Transducers
@cindex SRFI-171
@@ -5705,6 +5735,7 @@ left-to-right, due to how transducers are initiated.
* SRFI-171 Helpers:: Utilities for writing your own
transducers
@end menu
+
@node SRFI-171 General Discussion
@subsubsection SRFI-171 General Discussion
@cindex transducers discussion
diff --git a/module/language/wisp.scm b/module/language/wisp.scm
new file mode 100644
index 000000000..dae9642ae
--- /dev/null
+++ b/module/language/wisp.scm
@@ -0,0 +1,776 @@
+;;; Wisp
+
+;; Copyright (C) 2013, 2017, 2018, 2020 Free Software Foundation, Inc.
+;; Copyright (C) 2014--2023 Arne Babenhauserheide.
+;; Copyright (C) 2023 Maxime Devos <maximedevos@telenet.be>
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+
+;; Scheme-only implementation of a wisp-preprocessor which output a
+;; Scheme code tree to feed to a Scheme interpreter instead of a
+;; preprocessed file.
+
+;; Limitations:
+;; - in some cases the source line information is missing in backtraces.
+;; check for set-source-property!
+
+;;; Code:
+
+(define-module (language wisp)
+ #:export (wisp-scheme-read-chunk wisp-scheme-read-all
+ wisp-scheme-read-file-chunk
wisp-scheme-read-file
+ wisp-scheme-read-string)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11); for let-values
+ #:use-module (srfi srfi-9); for records
+ #:use-module (ice-9 rw); for write-string/partial
+ #:use-module (ice-9 match))
+
+;; use curly-infix by default
+(eval-when (expand load eval)
+ (read-enable 'curly-infix))
+
+
+;; Helpers to preserver source properties
+
+(define (wisp-add-source-properties-from source target)
+ "Copy the source properties from source into the target and return the
target."
+ (catch #t
+ (lambda ()
+ (set-source-properties! target (source-properties source)))
+ (lambda (key . arguments)
+ #f))
+ target)
+
+(define (wisp-add-source-properties-from/when-required source target)
+ "Copy the source properties if target has none."
+ (if (null? (source-properties target))
+ (wisp-add-source-properties-from source target)
+ target))
+
+
+;; Helper functions for the indent-and-symbols data structure: '((indent token
token ...) ...)
+(define make-line list)
+
+(define (line-indent line)
+ (car line))
+
+(define (line-real-indent line)
+ "Get the indentation without the comment-marker for unindented lines (-1 is
treated as 0)."
+ (let ((indent (line-indent line)))
+ (if (= -1 indent)
+ 0
+ indent)))
+
+(define (line-code line)
+ "Strip the indentation markers from the beginning of the line and preserve
source-properties"
+ (let ((code (cdr line)))
+ ;; propagate source properties
+ (when (not (null? code))
+ (wisp-add-source-properties-from/when-required line code))
+ code))
+
+;; literal values I need
+(define readcolon
+ (string->symbol ":"))
+
+(define wisp-uuid "e749c73d-c826-47e2-a798-c16c13cb89dd")
+;; define an intermediate dot replacement with UUID to avoid clashes.
+(define repr-dot ; .
+ (string->symbol (string-append "REPR-DOT-" wisp-uuid)))
+
+;; allow using reader additions as the first element on a line to prefix the
list
+(define repr-quote ; '
+ (string->symbol (string-append "REPR-QUOTE-" wisp-uuid)))
+(define repr-unquote ; ,
+ (string->symbol (string-append "REPR-UNQUOTE-" wisp-uuid)))
+(define repr-quasiquote ; `
+ (string->symbol (string-append "REPR-QUASIQUOTE-" wisp-uuid)))
+(define repr-unquote-splicing ; ,@
+ (string->symbol (string-append "REPR-UNQUOTESPLICING-" wisp-uuid)))
+
+(define repr-syntax ; #'
+ (string->symbol (string-append "REPR-SYNTAX-" wisp-uuid)))
+(define repr-unsyntax ; #,
+ (string->symbol (string-append "REPR-UNSYNTAX-" wisp-uuid)))
+(define repr-quasisyntax ; #`
+ (string->symbol (string-append "REPR-QUASISYNTAX-" wisp-uuid)))
+(define repr-unsyntax-splicing ; #,@
+ (string->symbol (string-append "REPR-UNSYNTAXSPLICING-" wisp-uuid)))
+
+;; TODO: wrap the reader to return the repr of the syntax reader
+;; additions
+
+(define (equal-rest? chars . args)
+ (equal? chars args))
+
+(define (match-charlist-to-repr char-list)
+ (let ((chars (reverse char-list)))
+ (cond
+ ((equal-rest? chars #\.) repr-dot)
+ ((equal-rest? chars #\') repr-quote)
+ ((equal-rest? chars #\,) repr-unquote)
+ ((equal-rest? chars #\`) repr-quasiquote)
+ ((equal-rest? chars #\, #\@) repr-unquote-splicing)
+ ((equal-rest? chars #\# #\') repr-syntax)
+ ((equal-rest? chars #\# #\,) repr-unsyntax)
+ ((equal-rest? chars #\# #\`) repr-quasisyntax)
+ ((equal-rest? chars #\# #\, #\@) repr-unsyntax-splicing)
+ (else #f))))
+
+(define (wisp-read port)
+ "Wrap read to catch list prefixes: read one or several chars from PORT and
return read symbols or replacement-symbols as representation for special forms."
+ (let ((prefix-maxlen 4))
+ (let longpeek ((peeked '()) (repr-symbol #f))
+ (cond
+ ((or (< prefix-maxlen (length peeked))
+ (eof-object? (peek-char port))
+ (equal? #\space (peek-char port))
+ (equal? #\newline (peek-char port)))
+ (if repr-symbol ; found a special symbol, return it.
+ repr-symbol
+ (let unpeek ((remaining peeked))
+ (cond
+ ((equal? '() remaining)
+ (read port)); let read to the work
+ (else
+ (unread-char (car remaining) port)
+ (unpeek (cdr remaining)))))))
+ (else
+ (let* ((next-char (read-char port))
+ (peeked (cons next-char peeked)))
+ (longpeek
+ peeked
+ (match-charlist-to-repr peeked))))))))
+
+
+
+(define (line-continues? line)
+ (equal? repr-dot (car (line-code line))))
+
+(define (line-only-colon? line)
+ (and
+ (equal? ":" (car (line-code line)))
+ (null? (cdr (line-code line)))))
+
+(define (line-empty-code? line)
+ (null? (line-code line)))
+
+(define (line-empty? line)
+ (and
+ ;; if indent is -1, we stripped a comment, so the line was not really empty.
+ (= 0 (line-indent line))
+ (line-empty-code? line)))
+
+(define (line-strip-continuation line)
+ (if (line-continues? line)
+ (apply make-line
+ (line-indent line)
+ (cdr (line-code line)))
+ line))
+
+(define (line-strip-indentation-marker line)
+ "Strip the indentation markers from the beginning of the line for
line-finalize without propagating source-properties (those are propagated in a
second step)"
+ (cdr line))
+
+(define (indent-level-reduction indentation-levels level select-fun)
+ "Reduce the INDENTATION-LEVELS to the given LEVEL and return the value
selected by SELECT-FUN"
+ (let loop ((newlevels indentation-levels)
+ (diff 0))
+ (cond
+ ((= level (car newlevels))
+ (select-fun (list diff indentation-levels)))
+ ((< level (car newlevels))
+ (loop
+ (cdr newlevels)
+ (1+ diff)))
+ (else
+ (raise-exception (make-exception-from-throw 'wisp-syntax-error (list
(format #f "Level ~A not found in the indentation-levels ~A." level
indentation-levels))))))))
+
+(define (indent-level-difference indentation-levels level)
+ "Find how many indentation levels need to be popped off to find the given
level."
+ (indent-level-reduction indentation-levels level
+ (lambda (x); get the count
+ (car x))))
+
+(define (indent-reduce-to-level indentation-levels level)
+ "Find how many indentation levels need to be popped off to find the given
level."
+ (indent-level-reduction indentation-levels level
+ (lambda (x); get the levels
+ (car (cdr x)))))
+
+(define (chunk-ends-with-period currentsymbols next-char)
+ "Check whether indent-and-symbols ends with a period, indicating the end of
a chunk."
+ (and (not (null? currentsymbols))
+ (equal? #\newline next-char)
+ (equal? repr-dot
+ (list-ref currentsymbols (- (length currentsymbols) 1)))))
+
+
+(define (wisp-scheme-read-chunk-lines port)
+ ;; the line number for this chunk is the line number when starting to read it
+ ;; a top-level form stops processing, so we only need to retrieve this here.
+ (define line-number (port-line port))
+ (let loop ((indent-and-symbols (list)); '((5 "(foobar)" "\"yobble\"")(3
"#t"))
+ (in-indent? #t)
+ (in-underscoreindent? (equal? #\_ (peek-char port)))
+ (in-comment? #f)
+ (currentindent 0)
+ (currentsymbols '())
+ (emptylines 0))
+ (cond
+ ((>= emptylines 2)
+ ;; the chunk end has to be checked
+ ;; before we look for new chars in the
+ ;; port to make execution in the REPL
+ ;; after two empty lines work
+ ;; (otherwise it shows one more line).
+ indent-and-symbols)
+ (else
+ (let ((next-char (peek-char port)))
+ (cond
+ ((eof-object? next-char)
+ (let ((line (apply make-line currentindent currentsymbols)))
+ (set-source-property! line 'filename (port-filename port))
+ (set-source-property! line 'line line-number)
+ (append indent-and-symbols (list line))))
+ ((and in-indent?
+ (zero? currentindent)
+ (not in-comment?)
+ (not (null? indent-and-symbols))
+ (not in-underscoreindent?)
+ (not (or (equal? #\space next-char)
+ (equal? #\newline next-char)
+ (equal? (string-ref ";" 0) next-char))))
+ (append indent-and-symbols)); top-level form ends chunk
+ ((chunk-ends-with-period currentsymbols next-char)
+ ;; the line ends with a period. This is forbidden in
+ ;; SRFI-119. Use it to end the line in the REPL without
+ ;; showing continuation dots (...).
+ (append indent-and-symbols (list (apply make-line currentindent
(drop-right currentsymbols 1)))))
+ ((and in-indent? (equal? #\space next-char))
+ (read-char port); remove char
+ (loop
+ indent-and-symbols
+ #t ; in-indent?
+ #f ; in-underscoreindent?
+ #f ; in-comment?
+ (1+ currentindent)
+ currentsymbols
+ emptylines))
+ ((and in-underscoreindent? (equal? #\_ next-char))
+ (read-char port); remove char
+ (loop
+ indent-and-symbols
+ #t ; in-indent?
+ #t ; in-underscoreindent?
+ #f ; in-comment?
+ (1+ currentindent)
+ currentsymbols
+ emptylines))
+ ;; any char but whitespace *after* underscoreindent is
+ ;; an error. This is stricter than the current wisp
+ ;; syntax definition.
+ ;; TODO: Fix the definition. Better start too strict.
+ ;; FIXME: breaks on lines with only underscores which should be
+ ;; empty lines.
+ ((and in-underscoreindent? (and (not (equal? #\space next-char)) (not
(equal? #\newline next-char))))
+ (raise-exception (make-exception-from-throw 'wisp-syntax-error (list
"initial underscores without following whitespace at beginning of the line
after" (last indent-and-symbols)))))
+ ((equal? #\newline next-char)
+ (read-char port); remove the newline
+ (let*
+ ;; distinguish pure whitespace lines and lines
+ ;; with comment by giving the former zero
+ ;; indent. Lines with a comment at zero indent
+ ;; get indent -1 for the same reason - meaning
+ ;; not actually empty.
+ ((indent
+ (cond
+ (in-comment?
+ (if (= 0 currentindent); specialcase
+ -1
+ currentindent))
+ ((not (null? currentsymbols)); pure whitespace
+ currentindent)
+ (else
+ 0)))
+ (parsedline (apply make-line indent currentsymbols))
+ (emptylines
+ (if (not (line-empty? parsedline))
+ 0
+ (1+ emptylines))))
+ (when (not (= 0 (length (line-code parsedline))))
+ ;; set the source properties to parsedline so we can try to add
them later.
+ (set-source-property! parsedline 'filename (port-filename port))
+ (set-source-property! parsedline 'line line-number))
+ ;; TODO: If the line is empty. Either do it here and do not add
it, just
+ ;; increment the empty line counter, or strip it later. Replace
indent
+ ;; -1 by indent 0 afterwards.
+ (loop
+ (append indent-and-symbols (list parsedline))
+ #t ; in-indent?
+ (if (<= 2 emptylines)
+ #f ; chunk ends here
+ (equal? #\_ (peek-char port))); are we in underscore indent?
+ #f ; in-comment?
+ 0
+ '()
+ emptylines)))
+ ((equal? #t in-comment?)
+ (read-char port); remove one comment character
+ (loop
+ indent-and-symbols
+ #f ; in-indent?
+ #f ; in-underscoreindent?
+ #t ; in-comment?
+ currentindent
+ currentsymbols
+ emptylines))
+ ((or (equal? #\space next-char) (equal? #\tab next-char) (equal?
#\return next-char)); remove whitespace when not in indent
+ (read-char port); remove char
+ (loop
+ indent-and-symbols
+ #f ; in-indent?
+ #f ; in-underscoreindent?
+ #f ; in-comment?
+ currentindent
+ currentsymbols
+ emptylines))
+ ;; | cludge to appease the former wisp parser
+ ;; | used for bootstrapping which has a
+ ;; v problem with the literal comment char
+ ((equal? (string-ref ";" 0) next-char)
+ (loop
+ indent-and-symbols
+ #f ; in-indent?
+ #f ; in-underscoreindent?
+ #t ; in-comment?
+ currentindent
+ currentsymbols
+ emptylines))
+ (else ; use the reader
+ (loop
+ indent-and-symbols
+ #f ; in-indent?
+ #f ; in-underscoreindent?
+ #f ; in-comment?
+ currentindent
+ ;; this also takes care of the hashbang and leading comments.
+ (append currentsymbols (list (wisp-read port)))
+ emptylines))))))))
+
+
+(define (line-code-replace-inline-colons line)
+ "Replace inline colons by opening parens which close at the end of the line"
+ ;; format #t "replace inline colons for line ~A\n" line
+ (let loop ((processed '())
+ (unprocessed line))
+ (cond
+ ((null? unprocessed)
+ ;; format #t "inline-colons processed line: ~A\n" processed
+ processed)
+ ;; replace : . with nothing
+ ((and (<= 2 (length unprocessed)) (equal? readcolon (car unprocessed))
(equal? repr-dot (car (cdr unprocessed))))
+ (loop
+ (append processed
+ (loop '() (cdr (cdr unprocessed))))
+ '()))
+ ((equal? readcolon (car unprocessed))
+ (loop
+ (append processed
+ (list (loop '() (cdr unprocessed))))
+ '()))
+ (else
+ (loop
+ (append processed
+ (list (car unprocessed)))
+ (cdr unprocessed))))))
+
+(define (line-replace-inline-colons line)
+ (cons
+ (line-indent line)
+ (line-code-replace-inline-colons (line-code line))))
+
+(define (line-strip-lone-colon line)
+ "A line consisting only of a colon is just a marked indentation level. We
need to kill the colon before replacing inline colons."
+ (if (equal? (line-code line) (list readcolon))
+ (make-line (line-indent line))
+ line))
+
+(define (line-finalize line)
+ "Process all wisp-specific information in a line and strip it"
+ (let ((l (line-code-replace-inline-colons
+ (line-strip-indentation-marker
+ (line-strip-lone-colon
+ (line-strip-continuation line))))))
+ (when (not (null? (source-properties line)))
+ (catch #t
+ (lambda ()
+ (set-source-properties! l (source-properties line)))
+ (lambda (key . arguments)
+ #f)))
+ l))
+
+(define (wisp-propagate-source-properties code)
+ "Propagate the source properties from the sourrounding list into every part
of the code."
+ (let loop ((processed '())
+ (unprocessed code))
+ (cond
+ ((and (null? processed) (not (pair? unprocessed)) (not (list?
unprocessed)))
+ unprocessed)
+ ((and (pair? unprocessed) (not (list? unprocessed)))
+ (cons
+ (wisp-propagate-source-properties (car unprocessed))
+ (wisp-propagate-source-properties (cdr unprocessed))))
+ ((null? unprocessed)
+ processed)
+ (else
+ (let ((line (car unprocessed)))
+ (wisp-add-source-properties-from/when-required line unprocessed)
+ (wisp-add-source-properties-from/when-required code unprocessed)
+ (wisp-add-source-properties-from/when-required unprocessed line)
+ (wisp-add-source-properties-from/when-required unprocessed code)
+ (let ((processed (append processed (list
(wisp-propagate-source-properties line)))))
+ ;; must propagate from line, because unprocessed and code can be
null, then they cannot keep source-properties.
+ (wisp-add-source-properties-from/when-required line processed)
+ (loop processed
+ (cdr unprocessed))))))))
+
+(define* (wisp-scheme-indentation-to-parens lines)
+ "Add parentheses to lines and remove the indentation markers"
+ (when
+ (and
+ (not (null? lines))
+ (not (line-empty-code? (car lines)))
+ (not (= 0 (line-real-indent (car lines))))); -1 is a line with a comment
+ (if (= 1 (line-real-indent (car lines)))
+ ;; accept a single space as indentation of the first line (and ignore
the indentation) to support meta commands
+ (set! lines
+ (cons
+ (cons 0 (cdr (car lines)))
+ (cdr lines)))
+ (raise-exception
+ (make-exception-from-throw
+ 'wisp-syntax-error
+ (list
+ (format #f "The first symbol in a chunk must start at zero
indentation. Indentation and line: ~A"
+ (car lines)))))))
+ (let loop ((processed '())
+ (unprocessed lines)
+ (indentation-levels '(0)))
+ (let* ((current-line
+ (if (<= 1 (length unprocessed))
+ (car unprocessed)
+ (make-line 0))); empty code
+ (next-line
+ (if (<= 2 (length unprocessed))
+ (car (cdr unprocessed))
+ (make-line 0))); empty code
+ (current-indentation
+ (car indentation-levels))
+ (current-line-indentation (line-real-indent current-line)))
+ ;; format #t "processed: ~A\ncurrent-line: ~A\nnext-line:
~A\nunprocessed: ~A\nindentation-levels: ~A\ncurrent-indentation: ~A\n\n"
+ ;; . processed current-line next-line unprocessed indentation-levels
current-indentation
+ (cond
+ ;; the real end: this is reported to the outside world.
+ ((and (null? unprocessed) (not (null? indentation-levels)) (null? (cdr
indentation-levels)))
+ ;; reverse the processed lines, because I use cons.
+ processed)
+ ;; the recursion end-condition
+ ((and (null? unprocessed))
+ ;; this is the last step. Nothing more to do except
+ ;; for rolling up the indentation levels. return the
+ ;; new processed and unprocessed lists: this is a
+ ;; side-recursion
+ (values processed unprocessed))
+ ((null? indentation-levels)
+ (raise-exception
+ (make-exception-from-throw
+ 'wisp-programming-error
+ (list
+ "The indentation-levels are null but the current-line is null:
Something killed the indentation-levels."))))
+ (else ; now we come to the line-comparisons and indentation-counting.
+ (cond
+ ((line-empty-code? current-line)
+ ;; We cannot process indentation without
+ ;; code. Just switch to the next line. This should
+ ;; only happen at the start of the recursion.
+ (loop
+ processed
+ (cdr unprocessed)
+ indentation-levels))
+ ((and (line-empty-code? next-line) (<= 2 (length unprocessed)))
+ ;; take out the next-line from unprocessed.
+ (loop
+ processed
+ (cons current-line
+ (cdr (cdr unprocessed)))
+ indentation-levels))
+ ((> current-indentation current-line-indentation)
+ ;; this just steps back one level via the side-recursion.
+ (let ((previous-indentation (car (cdr indentation-levels))))
+ (if (<= current-line-indentation previous-indentation)
+ (values processed unprocessed)
+ (begin ;; not yet used level! TODO: maybe throw an error here
instead of a warning.
+ (let ((linenumber (- (length lines) (length unprocessed))))
+ (format (current-error-port) ";;; WARNING:~A: used lower
but undefined indentation level (line ~A of the current chunk: ~S). This makes
refactoring much more error-prone, therefore it might become an error in a
later version of Wisp.\n" (source-property current-line 'line) linenumber (cdr
current-line)))
+ (loop
+ processed
+ unprocessed
+ (cons ; recursion via the indentation-levels
+ current-line-indentation
+ (cdr indentation-levels)))))))
+ ((= current-indentation current-line-indentation)
+ (let ((line (line-finalize current-line))
+ (next-line-indentation (line-real-indent next-line)))
+ (cond
+ ((>= current-line-indentation next-line-indentation)
+ ;; simple recursiive step to the next line
+ (loop
+ (append processed
+ (if (line-continues? current-line)
+ line
+ (wisp-add-source-properties-from line (list line))))
+ (cdr unprocessed); recursion here
+ indentation-levels))
+ ((< current-line-indentation next-line-indentation)
+ ;; side-recursion via a sublist
+ (let-values
+ (((sub-processed sub-unprocessed)
+ (loop
+ line
+ (cdr unprocessed); recursion here
+ indentation-levels)))
+ (loop
+ (append processed (list sub-processed))
+ sub-unprocessed ; simply use the recursion from the
sub-recursion
+ indentation-levels))))))
+ ((< current-indentation current-line-indentation)
+ (loop
+ processed
+ unprocessed
+ (cons ; recursion via the indentation-levels
+ current-line-indentation
+ indentation-levels)))
+ (else
+ (raise-exception
+ (make-exception-from-throw
+ 'wisp-not-implemented
+ (list
+ (format #f "Need to implement further line comparison: current:
~A, next: ~A, processed: ~A."
+ current-line next-line processed)))))))))))
+
+
+(define (wisp-scheme-replace-inline-colons lines)
+ "Replace inline colons by opening parens which close at the end of the line"
+ (let loop ((processed '())
+ (unprocessed lines))
+ (if (null? unprocessed)
+ processed
+ (loop
+ (append processed (list (line-replace-inline-colons (car
unprocessed))))
+ (cdr unprocessed)))))
+
+
+(define (wisp-scheme-strip-indentation-markers lines)
+ "Strip the indentation markers from the beginning of the lines"
+ (let loop ((processed '())
+ (unprocessed lines))
+ (if (null? unprocessed)
+ processed
+ (loop
+ (append processed (cdr (car unprocessed)))
+ (cdr unprocessed)))))
+
+(define (wisp-unescape-underscore-and-colon code)
+ "replace \\_ and \\: by _ and :"
+ (wisp-add-source-properties-from/when-required
+ code
+ (cond ((list? code) (map wisp-unescape-underscore-and-colon code))
+ ((eq? code '\:) ':)
+ ;; Look for symbols like \____ and remove the \.
+ ((symbol? code)
+ (let ((as-string (symbol->string code)))
+ (if (and (>= (string-length as-string) 2) ; at least a single
underscore
+ (char=? (string-ref as-string 0) #\\)
+ (string-every #\_ (substring as-string 1)))
+ (string->symbol (substring as-string 1))
+ code)))
+ (#t code))))
+
+
+(define (wisp-replace-empty-eof code)
+ "replace ((#<eof>)) by ()"
+ ;; This is a hack which fixes a bug when the
+ ;; parser hits files with only hashbang and comments.
+ (if (and (not (null? code)) (pair? (car code)) (eof-object? (car (car
code))) (null? (cdr code)) (null? (cdr (car code))))
+ (wisp-add-source-properties-from code (list))
+ code))
+
+
+(define (wisp-replace-paren-quotation-repr code)
+ "Replace lists starting with a quotation symbol by
+ quoted lists."
+ (wisp-add-source-properties-from/when-required
+ code
+ (match code
+ (('REPR-QUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd a ...)
+ (list 'quote (map wisp-replace-paren-quotation-repr a)))
+ ((a ... 'REPR-QUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd b); this is the
quoted empty list
+ (append
+ (map wisp-replace-paren-quotation-repr a)
+ (list (list 'quote (map wisp-replace-paren-quotation-repr b)))))
+ (('REPR-QUASIQUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd
'REPR-UNQUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd a ...)
+ (list 'quasiquote (list 'unquote (map wisp-replace-paren-quotation-repr
a))))
+ (('REPR-UNQUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd a ...)
+ (list 'unquote (map wisp-replace-paren-quotation-repr a)))
+ ((a ... 'REPR-UNQUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd b)
+ (append
+ (map wisp-replace-paren-quotation-repr a)
+ (list (list 'unquote (map wisp-replace-paren-quotation-repr b)))))
+ (('REPR-QUASIQUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd a ...)
+ (list 'quasiquote (map wisp-replace-paren-quotation-repr a)))
+ ((a ... 'REPR-QUASIQUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd b); this is
the quoted empty list
+ (append
+ (map wisp-replace-paren-quotation-repr a)
+ (list (list 'quasiquote (map wisp-replace-paren-quotation-repr b)))))
+ (('REPR-UNQUOTESPLICING-e749c73d-c826-47e2-a798-c16c13cb89dd a ...)
+ (list 'unquote-splicing (map wisp-replace-paren-quotation-repr a)))
+ (('REPR-SYNTAX-e749c73d-c826-47e2-a798-c16c13cb89dd a ...)
+ (list 'syntax (map wisp-replace-paren-quotation-repr a)))
+ (('REPR-UNSYNTAX-e749c73d-c826-47e2-a798-c16c13cb89dd a ...)
+ (list 'unsyntax (map wisp-replace-paren-quotation-repr a)))
+ (('REPR-QUASISYNTAX-e749c73d-c826-47e2-a798-c16c13cb89dd a ...)
+ (list 'quasisyntax (map wisp-replace-paren-quotation-repr a)))
+ (('REPR-UNSYNTAXSPLICING-e749c73d-c826-47e2-a798-c16c13cb89dd a ...)
+ (list 'unsyntax-splicing (map wisp-replace-paren-quotation-repr a)))
+ ;; literal array as start of a line: # (a b) c -> (#(a b) c)
+ ((#\# a ...)
+ (with-input-from-string ;; hack to defer to read
+ (string-append "#"
+ (with-output-to-string
+ (λ ()
+ (write (map wisp-replace-paren-quotation-repr a)
+ (current-output-port)))))
+ read))
+ ((a ...)
+ (map wisp-replace-paren-quotation-repr a))
+ (a
+ a))))
+
+(define (wisp-make-improper code)
+ "Turn (a #{.}# b) into the correct (a . b).
+
+read called on a single dot creates a variable named #{.}# (|.|
+in r7rs). Due to parsing the indentation before the list
+structure is known, the reader cannot create improper lists
+when it reads a dot. So we have to take another pass over the
+code to recreate the improper lists.
+
+Match is awesome!"
+ (define is-proper? #t)
+ ;; local alias
+ (define (add-prop/req form)
+ (wisp-add-source-properties-from/when-required code form))
+ (wisp-add-source-properties-from/when-required
+ code
+ (let ((improper
+ (match code
+ ((a ... b 'REPR-DOT-e749c73d-c826-47e2-a798-c16c13cb89dd c)
+ (set! is-proper? #f)
+ (wisp-add-source-properties-from/when-required
+ code
+ (append (map wisp-make-improper (map add-prop/req a))
+ (cons (wisp-make-improper (add-prop/req b))
+ (wisp-make-improper (add-prop/req c))))))
+ ((a ...)
+ (add-prop/req
+ (map wisp-make-improper (map add-prop/req a))))
+ (a
+ a))))
+ (define (syntax-error li msg)
+ (raise-exception
+ (make-exception-from-throw
+ 'wisp-syntax-error
+ (list (format #f "incorrect dot-syntax #{.}# in code: ~A: ~A" msg
li)))))
+ (if is-proper?
+ improper
+ (let check ((tocheck improper))
+ (match tocheck
+ ;; lists with only one member
+ (('REPR-DOT-e749c73d-c826-47e2-a798-c16c13cb89dd)
+ (syntax-error tocheck "list with the period as only member"))
+ ;; list with remaining dot.
+ ((a ...)
+ (if (and (member repr-dot a))
+ (syntax-error tocheck "leftover period in list")
+ (map check a)))
+ ;; simple pair - this and the next do not work when parsed from
wisp-scheme itself. Why?
+ (('REPR-DOT-e749c73d-c826-47e2-a798-c16c13cb89dd . c)
+ (syntax-error tocheck "dot as first element in already improper
pair"))
+ ;; simple pair, other way round
+ ((a . 'REPR-DOT-e749c73d-c826-47e2-a798-c16c13cb89dd)
+ (syntax-error tocheck "dot as last element in already improper
pair"))
+ ;; more complex pairs
+ ((? pair? a)
+ (let ((head (drop-right a 1))
+ (tail (last-pair a)))
+ (cond
+ ((equal? repr-dot (car tail))
+ (syntax-error tocheck "equal? repr-dot : car tail"))
+ ((equal? repr-dot (cdr tail))
+ (syntax-error tocheck "equal? repr-dot : cdr tail"))
+ ((member repr-dot head)
+ (syntax-error tocheck "member repr-dot head"))
+ (else
+ a))))
+ (a
+ a)))))))
+
+(define (wisp-scheme-read-chunk port)
+ "Read and parse one chunk of wisp-code"
+ (with-fluids ((%read-hash-procedures (fluid-ref %read-hash-procedures)))
+ (read-hash-extend #\# (lambda args #\#))
+ (let ((lines (wisp-scheme-read-chunk-lines port)))
+ (wisp-make-improper
+ (wisp-replace-empty-eof
+ (wisp-unescape-underscore-and-colon
+ (wisp-replace-paren-quotation-repr
+ (wisp-propagate-source-properties
+ (wisp-scheme-indentation-to-parens lines)))))))))
+
+(define (wisp-scheme-read-all port)
+ "Read all chunks from the given port"
+ (let loop ((tokens '()))
+ (cond
+ ((eof-object? (peek-char port))
+ tokens)
+ (else
+ (loop
+ (append tokens (wisp-scheme-read-chunk port)))))))
+
+(define (wisp-scheme-read-file path)
+ (call-with-input-file path wisp-scheme-read-all))
+
+(define (wisp-scheme-read-file-chunk path)
+ (call-with-input-file path wisp-scheme-read-chunk))
+
+(define (wisp-scheme-read-string str)
+ (call-with-input-string str wisp-scheme-read-all))
+
+(define (wisp-scheme-read-string-chunk str)
+ (call-with-input-string str wisp-scheme-read-chunk))
diff --git a/module/language/wisp/spec.scm b/module/language/wisp/spec.scm
new file mode 100644
index 000000000..f7fd794e0
--- /dev/null
+++ b/module/language/wisp/spec.scm
@@ -0,0 +1,70 @@
+;;; Language interface for Wisp in Guile
+
+;; Copyright (C) 2005--2014 by David A. Wheeler and Alan Manuel K. Gloria
+;; Copyright (C) 2014--2023 Arne Babenhauserheide.
+;; Copyright (C) 2023 Maxime Devos <maximedevos@telenet.be>
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;; adapted from spec.scm:
https://gitorious.org/nacre/guile-sweet/?p=nacre:guile-sweet.git;a=blob;f=sweet/spec.scm;hb=ae306867e371cb4b56e00bb60a50d9a0b8353109
+
+(define-module (language wisp spec)
+ #:use-module (language wisp)
+ #:use-module (system base compile)
+ #:use-module (system base language)
+ #:use-module (language scheme compile-tree-il)
+ #:use-module (language scheme decompile-tree-il)
+ #:export (wisp))
+
+;;;
+;;; Language definition
+;;;
+
+
+(define (read-one-wisp-sexp port env)
+ ;; Allow using "# foo" as #(foo).
+ ;; Don't use the globally-acting read-hash-extend, because this
+ ;; doesn't make much sense in parenthese-y (non-Wisp) Scheme.
+ ;; Instead, use fluids to temporarily add the extension.
+ (with-fluids ((%read-hash-procedures (fluid-ref %read-hash-procedures)))
+ (read-hash-extend #\# (lambda args #\# ))
+ ;; Read Wisp files as UTF-8, to support non-ASCII characters.
+ ;; TODO: would be nice to support ';; coding: whatever' lines
+ ;; like in parenthese-y Scheme.
+ (set-port-encoding! port "UTF-8")
+ (if (eof-object? (peek-char port))
+ (read-char port) ; return eof: we’re done
+ (let ((chunk (wisp-scheme-read-chunk port)))
+ (and (not (null? chunk)) ; <---- XXX: maybe (pair? chunk)
+ (car chunk))))))
+
+(define-language wisp
+ #:title "Wisp Scheme Syntax. See SRFI-119 for details"
+ ;; . #:reader read-one-wisp-sexp
+ #:reader read-one-wisp-sexp ; : lambda (port env) : let ((x
(read-one-wisp-sexp port env))) (display x)(newline) x ;
+ #:compilers `((tree-il . ,compile-tree-il))
+ #:decompilers `((tree-il . ,decompile-tree-il))
+ #:evaluator (lambda (x module) (primitive-eval x))
+ #:printer write ; TODO: backtransform to Wisp? Use source-properties?
+ #:make-default-environment
+ (lambda ()
+ ;; Ideally we'd duplicate the whole module hierarchy so that `set!',
+ ;; `fluid-set!', etc. don't have any effect in the current environment.
+ (let ((m (make-fresh-user-module)))
+ ;; Provide a separate `current-reader' fluid so that
+ ;; compile-time changes to `current-reader' are
+ ;; limited to the current compilation unit.
+ (module-define! m 'current-reader (make-fluid))
+ m)))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 81e63bce2..247d97746 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -162,7 +162,8 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-98.test \
tests/srfi-105.test \
tests/srfi-111.test \
- tests/srfi-171.test \
+ tests/srfi-119.test \
+ tests/srfi-171.test \
tests/srfi-4.test \
tests/srfi-9.test \
tests/statprof.test \
diff --git a/test-suite/tests/srfi-119.test b/test-suite/tests/srfi-119.test
new file mode 100644
index 000000000..5390a25b3
--- /dev/null
+++ b/test-suite/tests/srfi-119.test
@@ -0,0 +1,1040 @@
+;;;; srfi-119.test --- Test suite for Guile's SRFI-119 reader. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2023 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (test-srfi-119)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26) ;; cut
+ #:use-module (language wisp))
+
+(define (read-string s)
+ (with-input-from-string s read))
+
+(define (with-read-options opts thunk)
+ (let ((saved-options (read-options)))
+ (dynamic-wind
+ (lambda ()
+ (read-options opts))
+ thunk
+ (lambda ()
+ (read-options saved-options)))))
+
+(define (wisp->list str)
+ (wisp-scheme-read-string str))
+
+(define (scheme->list str)
+ (with-input-from-string str
+ (λ ()
+ (let loop ((result '()))
+ (if (eof-object? (peek-char))
+ (reverse! result)
+ (loop (cons (read) result)))))))
+
+(with-test-prefix "wisp-read-simple"
+ (pass-if-equal '((<= n 5))
+ (wisp->list "<= n 5"))
+ (pass-if-equal '(5)
+ (wisp->list ". 5"))
+ (pass-if-equal '((+ 1 (* 2 3)))
+ (wisp->list "+ 1 : * 2 3")))
+(with-test-prefix "wisp-read-complex"
+ (pass-if-equal '(
+ (a b c d e
+ f g h
+ i j k)
+
+ (concat "I want "
+ (getwish from me)
+ " - " username)) (wisp->list "
+a b c d e
+ . f g h
+ . i j k
+
+concat \"I want \"
+ getwish from me
+ . \" - \" username
+"))
+
+ (pass-if-equal
+ '(
+ (define (a b c)
+ (d e
+ (f)
+ (g h)
+ i))
+
+ (define (_)
+ (display "hello\n"))
+
+ (_)) (wisp->list "
+define : a b c
+_ d e
+___ f
+___ g h
+__ . i
+
+define : _
+_ display \"hello\n\"
+
+\\_"))
+
+ ;; nesting with pairs
+ (pass-if-equal '((1 . 2)(3 4 (5 . 6)))
+ (wisp->list "1 . 2\n3 4\n 5 . 6")))
+
+(with-test-prefix "wisp-source-properties"
+ ;; has properties
+ (pass-if (every pair? (map source-properties (wisp->list "1 . 2\n3 4\n 5 .
6"))))
+ (pass-if (every pair? (map source-properties (wisp->list "1 2\n3 4\n 5
6"))))
+ ;; has the same properties
+ (pass-if-equal
+ (map source-properties (scheme->list "(1 . 2)\n(3 4\n (5 . 6))\n(1
4)\n\n(7 8)"))
+ (map (cut cons '(filename . #f) <>)
+ (map source-properties (wisp->list "1 . 2\n3 4\n 5 . 6\n1 4\n\n7
8")))))
+
+(with-test-prefix "btest"
+ (pass-if-equal '((display "b")
+(newline)
+
+
+) (wisp->list "
+display \"b\"
+newline
+")))
+
+(with-test-prefix "continuation"
+ (pass-if-equal '((a b c d e
+ f g h
+ i j k)
+
+(concat "I want "
+ (getwish from me)
+ " - " username)
+
+
+
+) (wisp->list "
+a b c d e
+ . f g h
+ . i j k
+
+concat \"I want \"
+ getwish from me
+ . \" - \" username
+
+")))
+
+(with-test-prefix "dotted-pair"
+ (pass-if-equal '((use-modules ((ice-9 popen) #:select ((open-input-pipe .
oip))))
+
+
+ ) (wisp->list "
+use-modules : (ice-9 popen) #:select ((open-input-pipe . oip))
+")))
+
+(with-test-prefix "example"
+ (pass-if-equal '((defun a (b c)
+ (let
+ (
+ (d "i am a string
+do not break me!")
+ (
+ ; comment: 0
+ (f)
+; comment : 1
+ `(g )); comment " : " 2
+ (
+ (h (I am in brackets:
+ do not : change "me"))
+ i)))
+ ,('j k)
+
+ l
+
+; comment
+
+ (a c))
+
+(defun b (:n o)
+ "second defun : with a docstring!"
+ (message "I am here")
+ t)
+
+(defun c (e f)
+ ((g))
+ (
+ (h
+ (i))
+ (j))
+ '(())
+ (k)
+ l
+ (m))
+
+(defun _ (:)
+
+ :)
+
+(_ b)
+
+(defun d ()
+ (let
+ ((a b)
+ (c d))))
+
+(a (((c))))
+
+(let
+ ((a b)
+ (c)))
+
+(let ((a b)))
+
+a
+
+
+
+) (wisp->list "
+defun a (b c)
+ let
+ :
+ d \"i am a string
+do not break me!\"
+ :
+ ; comment: 0
+ f
+; comment : 1
+ ` g ; comment \" : \" 2
+ :
+ h (I am in brackets:
+ do not : change \"me\")
+ . i
+ , 'j k
+
+ . l
+
+; comment
+
+ a c
+
+defun b : :n o
+ . \"second defun : with a docstring!\"
+ message \"I am here\"
+ . t
+
+defun c : e f
+ : g
+ :
+ h
+ i
+ j
+ ' :
+ k
+ . l
+ . : m
+
+defun _ : \\:
+__
+__ . \\:
+
+\\_ b
+
+defun d :
+ let
+ : a b
+ c d
+
+a : : : c
+
+let
+ : a b
+ c
+
+let : : a b
+
+. a
+
+")))
+
+(with-test-prefix "factorial"
+ (pass-if-equal '(;; short version
+; note: once you use one inline colon, all the following forms on that
+; line will get closed at the end of the line
+
+(define (factorial n)
+ (if (zero? n)
+ 1
+ (* n (factorial (- n 1)))))
+
+(display (factorial 5 ))
+
+
+;; more vertical space, less colons
+(define (factorial n)
+ (if (zero? n)
+ 1
+ (* n
+ (factorial
+ (- n 1)))))
+
+(display (factorial 5 ))
+
+
+
+) (wisp->list "
+;; short version
+; note: once you use one inline colon, all the following forms on that
+; line will get closed at the end of the line
+
+define : factorial n
+ if : zero? n
+ . 1
+ * n : factorial : - n 1
+
+display : factorial 5
+
+
+;; more vertical space, less colons
+define : factorial n
+ if : zero? n
+ . 1
+ * n
+ factorial
+ - n 1
+
+display : factorial 5
+
+")))
+
+(with-test-prefix "fast-sum"
+ (pass-if-equal '((use-modules (srfi srfi-1))
+
+; only for the nice test
+#!curly-infix
+
+(define-syntax fast-sum
+ (syntax-rules (iota)
+ ((fast-sum (iota count start))
+ (+ 1
+ (apply -
+ (map (lambda (x) (/ {x * {x + 1} } 2))
+ (list {count + {start - 1}} start)))))
+ ((fast-sum e)
+ (apply + e))))
+
+
+) (wisp->list "
+use-modules : srfi srfi-1
+
+; only for the nice test
+. #!curly-infix
+
+define-syntax fast-sum
+ syntax-rules : iota
+ : fast-sum : iota count start
+ + 1
+ apply -
+ map : lambda (x) : / {x * {x + 1} } 2
+ list {count + {start - 1}} start
+ : fast-sum e
+ apply + e
+")))
+
+(with-test-prefix "flexible-parameter-list"
+ (pass-if-equal '(; Test using a . as first parameter on a line by prefixing
it with a second .
+(define
+ (a i
+ . b)
+ (unless (>= i (length b))
+ (display (number->string (length b )))
+ (display (list-ref b i))
+ (newline)
+ (apply a ( + i 1 ) b)))
+
+
+(a 0 "123" "345" "567")
+
+
+) (wisp->list "
+; Test using a . as first parameter on a line by prefixing it with a second .
+define
+ a i
+ . . b
+ unless : >= i : length b
+ display : number->string : length b
+ display : list-ref b i
+ newline
+ apply a ( + i 1 ) b
+
+
+a 0 \"123\" \"345\" \"567\"
+")))
+
+(with-test-prefix "hello"
+ (pass-if-equal '((define (hello who)
+ ;; include the newline
+ (format #t "~A ~A!\n"
+ "Hello" who))
+(hello "Wisp")
+
+) (wisp->list "
+define : hello who
+ ;; include the newline
+ format #t \"~A ~A!\\n\"
+ . \"Hello\" who
+hello \"Wisp\"
+")))
+
+(with-test-prefix "mtest"
+ (pass-if-equal '(#!/home/arne/wisp/wisp-multiline.sh !#
+
+(display 1)
+
+
+) (wisp->list "
+#!/home/arne/wisp/wisp-multiline.sh !#
+
+display 1
+")))
+
+(with-test-prefix "multiline-string"
+ (pass-if-equal '((display "
+ This is a
+ \"multi-line\"
+ string.
+ ")
+
+ ) (wisp->list "
+display \"
+ This is a
+ \\\"multi-line\\\"
+ string.
+ \"
+")))
+
+(with-test-prefix "namedlet"
+ (pass-if-equal '(#!/home/arne/wisp/wisp-multiline.sh
+; !#
+(define (hello who)
+ (display who))
+
+(let hello
+ ((who 0))
+ (if (= who 5)
+ (display who)
+ (hello (+ 1 who))))
+
+
+) (wisp->list "
+#!/home/arne/wisp/wisp-multiline.sh
+; !#
+define : hello who
+ display who
+
+let hello
+ : who 0
+ if : = who 5
+ display who
+ hello : + 1 who
+")))
+
+;; the following is no error, but produces a warning because indentation is
inconsistent.
+(with-test-prefix "partial-indent"
+ (pass-if-equal '((write
+ (list
+ (+ 1 2)
+ (+ 2 3)))
+(newline)
+
+(write
+ (list
+ (+ 1 2
+ (+ 3 4))
+ (+ 2 3)))
+(newline)
+
+
+) (wisp->list "
+write
+ list
+ + 1 2
+ + 2 3
+newline
+
+write
+ list
+ + 1 2
+ + 3 4
+ + 2 3
+newline
+")))
+
+(with-test-prefix "quotecolon"
+ (pass-if-equal '(#!/home/arne/wisp/wisp-multiline.sh
+; !#
+(define a 1 ); test whether ' : correctly gets turned into '(
+; and whether brackets in commments are treated correctly.
+
+(define a '(1 2 3))
+
+(define
+ (a b)
+ (c))
+
+(define a (quasiquote ,(+ 2 2)))
+) (wisp->list "
+#!/home/arne/wisp/wisp-multiline.sh
+; !#
+define a 1 ; test whether ' : correctly gets turned into '(
+; and whether brackets in commments are treated correctly.
+
+define a ' : 1 2 3
+
+define
+ a b
+ c
+
+define a : quasiquote , : + 2 2
+")))
+
+(with-test-prefix "range"
+ (pass-if-equal '((import (rnrs))
+
+(define range
+ (case-lambda
+ ((n ); one-argument syntax
+ (range 0 n 1))
+ ((n0 n ); two-argument syntax
+ (range n0 n 1))
+ ((n0 n s ); three-argument syntax
+ (assert
+ (and
+ (for-all number? (list n0 n s))
+ (not (zero? s))))
+ (let ((cmp (if (positive? s) >= <= )))
+ (let loop
+ ((i n0 )
+ (acc '()))
+ (if
+ (cmp i n )
+ (reverse acc)
+ (loop (+ i s) (cons i acc))))))))
+
+(display (apply string-append "" (map number->string (range 5))))
+(newline)
+
+) (wisp->list "
+import : rnrs
+
+define range
+ case-lambda
+ : n ; one-argument syntax
+ range 0 n 1
+ : n0 n ; two-argument syntax
+ range n0 n 1
+ : n0 n s ; three-argument syntax
+ assert
+ and
+ for-all number? : list n0 n s
+ not : zero? s
+ let : : cmp : if (positive? s) >= <=
+ let loop
+ : i n0
+ acc '()
+ if
+ cmp i n
+ reverse acc
+ loop (+ i s) (cons i acc)
+
+display : apply string-append \"\" : map number->string : range 5
+newline")))
+
+(with-test-prefix "readable-tests"
+ (pass-if-equal '((define (fibfast n)
+ (if (< n 2))
+ n
+ (fibup n 2 1 0 ))
+
+(define (fibup maxnum count n-1 n-2)
+ (if (= maxnum count)
+ (+ n-1 n-2)
+ (fibup maxnum
+ (+ count 1 )
+ (+ n-1 n-2 )
+ n-1)))
+
+(define (factorial n)
+ (if (<= n 1)
+ 1
+ (* n
+ (factorial (- n 1)))))
+
+(define (gcd x y)
+ (if (= y 0))
+ x
+ (gcd y
+ (rem x y)))
+
+(define (add-if-all-numbers lst)
+ (call/cc
+ (lambda (exit)
+ (let loop
+ (
+ (lst lst )
+ (sum 0))
+ (if (null? lst)
+ sum
+ (if (not (number? (car lst)))
+ (exit #f)
+ (+ (car lst)
+ (loop (cdr lst)))))))))
+
+) (wisp->list "
+define : fibfast n
+ if : < n 2
+ . n
+ fibup n 2 1 0
+
+define : fibup maxnum count n-1 n-2
+ if : = maxnum count
+ + n-1 n-2
+ fibup maxnum
+ + count 1
+ + n-1 n-2
+ . n-1
+
+define : factorial n
+ if : <= n 1
+ . 1
+ * n
+ factorial : - n 1
+
+define (gcd x y)
+ if (= y 0)
+ . x
+ gcd y
+ rem x y
+
+define : add-if-all-numbers lst
+ call/cc
+ lambda : exit
+ let loop
+ :
+ lst lst
+ sum 0
+ if : null? lst
+ . sum
+ if : not : number? : car lst
+ exit #f
+ + : car lst
+ loop : cdr lst")))
+
+(with-test-prefix "receive"
+ (pass-if-equal '((import (ice-9 receive) (srfi srfi-1))
+(write
+ (receive (car cdr)
+ (car+cdr '(car . cdr))
+ car))
+) (wisp->list "
+import (ice-9 receive) (srfi srfi-1)
+write
+ receive : car cdr
+ car+cdr '(car . cdr)
+ . car
+")))
+
+(with-test-prefix "self-referencial"
+ (pass-if-equal '(;
http://stackoverflow.com/questions/23167464/scheme-self-reference-lambda-macro
+; because this is as cool as things get
+(define-syntax slambda
+ (lambda (x)
+ (syntax-case x ()
+ ((slambda formals body0 body1 ...)
+ (with-syntax
+ ((self (datum->syntax #'slambda 'self)))
+ #'(letrec ((self (lambda formals body0 body1 ...)))
+ self))))))
+
+
+
+(
+ (slambda (x) (+ x 1))
+ 10)
+
+((slambda () self))
+
+
+
+) (wisp->list "
+;
http://stackoverflow.com/questions/23167464/scheme-self-reference-lambda-macro
+; because this is as cool as things get
+define-syntax slambda
+ lambda : x
+ syntax-case x :
+ : slambda formals body0 body1 ...
+ with-syntax
+ : self : datum->syntax #'slambda 'self
+ #' letrec : : self : lambda formals body0 body1 ...
+ . self
+
+
+
+:
+ slambda (x) : + x 1
+ . 10
+
+: slambda () self
+
+")))
+
+(with-test-prefix "shebang"
+ (pass-if-equal '(#!/usr/bin/wisp.py # !#
+; This tests shebang lines
+
+
+ ) (wisp->list "
+#!/usr/bin/wisp.py # !#
+; This tests shebang lines
+")))
+
+(with-test-prefix "strangecomments"
+ (pass-if-equal '((use-modules (wisp-scheme))
+; works
+(display
+ (call-with-input-string "foo ; bar\n ; nop \n\n; nup\n; nup \n \n\n\n
foo : moo \"\n\" \n___ . goo . hoo" wisp-scheme-read-chunk))
+(newline)
+(display
+ (call-with-input-string "foo \n___ . goo . hoo" wisp-scheme-read-chunk))
+(newline)
+
+) (wisp->list "
+use-modules : wisp-scheme
+; works
+display
+ call-with-input-string \"foo ; bar\\n ; nop \\n\\n; nup\\n; nup \\n
\\n\\n\\n foo : moo \\\"\\n\\\" \\n___ . goo . hoo\" wisp-scheme-read-chunk
+newline
+display
+ call-with-input-string \"foo \\n___ . goo . hoo\" wisp-scheme-read-chunk
+newline
+")))
+
+(with-test-prefix "sublist"
+(pass-if-equal '(; sublists allow to start single line function calls with a
colon ( : ).
+
+(defun a (b c)
+ (let ((e . f))
+ g))
+
+
+) (wisp->list "
+; sublists allow to start single line function calls with a colon ( : ).
+;
+defun a : b c
+ let : : e . f
+ . g
+ ")))
+
+(with-test-prefix "sxml"
+(pass-if-equal '((use-modules (sxml simple))
+(use-modules (ice-9 match))
+
+; define a template
+(define template
+ (quote
+ (html
+ (head (title "test"))
+ (body
+ (h1 "test")
+ (message "the header")
+ (p "it " (em "works!")
+ (br)
+ (" it actually works!"))))))
+
+; transform it
+(define template2
+ (let loop
+ ((l template))
+ (match l
+ (('message a ...)
+ `(p (@ (style "margin-left: 2em"))
+ (strong ,(map loop a))))
+ ((a ...)
+ (map loop a ))
+ (a
+ a))))
+
+; write xml to the output port
+(sxml->xml template2)
+
+(newline)
+
+
+) (wisp->list "
+ use-modules : sxml simple
+use-modules : ice-9 match
+
+; define a template
+define template
+ quote
+ html
+ head : title \"test\"
+ body
+ h1 \"test\"
+ message \"the header\"
+ p \"it \" : em \"works!\"
+ br
+ \" it actually works!\"
+
+; transform it
+define template2
+ let loop
+ : l template
+ match l
+ : 'message a ...
+ ` p : @ : style \"margin-left: 2em\"
+ strong ,(map loop a)
+ : a ...
+ map loop a
+ a
+ . a
+
+; write xml to the output port
+sxml->xml template2
+
+newline
+")))
+
+(with-test-prefix "syntax-colon"
+(pass-if-equal '((let
+ (
+ (a 1)
+ (b 2))
+ (let
+ (
+ (
+ c 3))
+ (format #t "a: ~A, b: ~A, c: ~A"
+ a b c)))
+
+((a))
+
+(define (hello)
+ (display "hello\n"))
+
+(let
+ ((a 1)
+ (b 2))
+ (format #t "a: ~A, b: ~A"
+ a b))
+
+(let ((a '())))
+
+(let
+ ( ; foo
+ (a
+ '())))
+
+(
+ (a))
+
+(define (:)
+ (hello))
+
+(:)
+
+
+) (wisp->list "
+let
+ :
+ a 1
+ b 2
+ let
+ :
+ :
+ . c 3
+ format #t \"a: ~A, b: ~A, c: ~A\"
+ . a b c
+
+: a
+
+define : hello
+ display \"hello\\n\"
+
+let
+ : a 1
+ b 2
+ format #t \"a: ~A, b: ~A\"
+ . a b
+
+let : : a ' :
+
+let
+ : ; foo
+ a
+ '
+
+:
+ a
+
+define : \\:
+ hello
+
+\\:
+")))
+
+(with-test-prefix "syntax-dot"
+(pass-if-equal '((define (foo)
+ "bar")
+
+(define (bar)
+ '(1
+ . 2 )); pair
+
+(display (foo))
+(newline)
+(display (bar))
+(newline)
+
+
+) (wisp->list "
+define : foo
+ . \"bar\"
+
+define : bar
+ ' 1
+ . . 2 ; pair
+
+display : foo
+newline
+display : bar
+newline
+")))
+
+(with-test-prefix "syntax-empty"
+(pass-if-equal '() (wisp->list "
+")))
+
+(with-test-prefix "syntax-indent"
+(pass-if-equal '((define
+ (hello who)
+ (format #t "Hello ~A\n" who))
+
+(define
+ (let
+ (
+ (a 1)
+ (b 2)
+ (c 3))
+ (format #t "a: ~A, b: ~A, c: ~A"
+ (+ a 2)
+ b c)))
+
+
+
+) (wisp->list "define
+ hello who
+ format #t \"Hello ~A\\n\" who
+
+define
+ let
+ :
+ a 1
+ b 2
+ c 3
+ format #t \"a: ~A, b: ~A, c: ~A\"
+ + a 2
+ . b c
+
+ ")))
+
+(with-test-prefix "syntax-strings-parens"
+(pass-if-equal '(; Test linebreaks in strings and brackets
+
+"flubbub
+
+flabbab"
+
+(hrug (nadda
+madda gadda "shoktom
+ mee" " sep
+ka"
+ hadda)
+ (gom))
+
+(flu)
+
+(sum [foo
+bar] barz {1 + [* 2 2]})
+
+(mara {
+li
++
+lo - (mabba)
+})
+) (wisp->list "
+; Test linebreaks in strings and brackets
+
+. \"flubbub
+
+flabbab\"
+
+hrug (nadda
+madda gadda \"shoktom
+ mee\" \" sep
+ka\"
+ hadda)
+ gom
+
+flu
+
+sum [foo
+bar] barz {1 + [* 2 2]}
+
+mara {
+li
++
+lo - (mabba)
+}
+")))
+
+(with-test-prefix "syntax-underscore"
+(pass-if-equal '((define (a b c)
+ (d e
+ (f)
+ (g h)
+ i))
+
+(define (_)
+ (display "hello\n"))
+
+(_)
+
+
+) (wisp->list "
+define : a b c
+_ d e
+___ f
+___ g h
+__ . i
+
+define : _
+_ display \"hello\\n\"
+
+\\_
+")))
+