(Arne Babenhauserheide)
2015-09-11: merge merge
diff --git a/.hgsigs b/.hgsigs
--- a/.hgsigs
+++ b/.hgsigs
@@ -20,3 +20,4 @@ fed7f4d46a41b0814c81eb08dcdb506b38321c61
36b8c0daff2cd8cadb73b0dcc19c16a60f5b58eb 0 iJwEAAEIAAYFAlUKBPEACgkQ3M8NswvBBUgDugP8C6yJk7LyLOFMGoKLmnBin1dc9uuaj7idhx24tjgLjxLoM06I6QxkWPSEoKgVUR01Euu0EbXaoJogAaOUlaUTZPeSeSAZStvTmXveWL4P1VIQoERy1hmia+tMPxQKXkXf5R0YRwdmiqOh1AoH8dVdkCsCfplBc3VGrdDN4caZP00=
a8ea98c78d90ae3e1b4daaf4bab3e2a7a847a06f 0 iJwEAAEIAAYFAlUoSqEACgkQ3M8NswvBBUihJQP/XB8kHNEcsTj5pgBtMepmIX/3CmVaz6ZNgzhSzJSS1oz2DMbXPJh32QaDwRd5wCoNksD00ch7e9UWhTSZztI/yDY9KwZrTV/OIDFzIdfSsdDO4J0WNxHmgymHSfitCjHcgSvT/C9/mubhNECPrQQUx08FMnNiNvcmGpwVOwakNNw=
41a3bcb0e07cff2119e6df4574afe7af01231724 0 iQEcBAABAgAGBQJViY75AAoJEFyD82SnDaCexVAH/1TKjisW+ka4V+1Hk6L+rd+35Migij9RzfMYwfaHzi9GtpuqkDrjrRxlh8R6P/b+bHTTXwfcZ1mk6Otstsutg/469qBfF5Mb09Zoi0y4g6xt6O75Jcac8vT3Sx22hUoh0GwqRMd7DZcNjO8tTOwV0Ssraqs2VURXwIF11D9g8weconamgQqs7uWgQ4Ku6qUXFfbzv0Sk3GHCyRfzwu3IZkvXymi+sVBNmq9Wtzn14tTsgOeFSmDL8EREK/yENyckzZbxbLO8TrNmL2VeZ6SidBDOaf9nDoyh2dWYdi10dxt7lbjcaPlYXEdSxm3V7fSp8d/kF5DMuefcGThZfKsE5aM=
+22bf6277df51f10ca9192bde088e6c062f9190a8 0 iQEcBAABAgAGBQJVt5NXAAoJEFyD82SnDaCevQIH/RIYkKQLBklUHMYvHO655PXNAHpU0OSMAjnggTiuNrY6IZqQASj/AWdAopPXMh5KrJ25Sg5ktlnxEw5paA68CFZCsc9HHuBwffkgN1kjOqafyI9FA46obCCnly1Mpo4814R+LbdUtcPerTDy4cJq6FlQal2l130Hi0ASVvfqqT73NbAl3EtBnYF2ecTiklHiUCZLlgMUXSBf3UxF3xzoY1g1tbtktVTVHbh+MDYPjpaM3y2CiYCaicS2kMyFRaNGEmh+4oHSAwEu9i6pZQtuhJItehbT+qNDJMc+Zs5DmYbH60Osv1mVn9MjQTeKoIWuBRHyPwuZXOstaYlNkSNqsvI=
diff --git a/.hgtags b/.hgtags
--- a/.hgtags
+++ b/.hgtags
@@ -29,3 +29,4 @@ 327acbae68ef4efbf77734f0ee20359ed559ce0d
41c48043ca33bf47311a93d0545b13a0578c3cf0 v0.8.3
a4bca2a0f2f6659d97b1db471ae9803119b80529 v0.8.4
f0096bf5f3baee5017be94f49c70515fe2a535b3 wisp-mode-0.2.1
+fb551bbe7084d22ef0c8e35df3864eb2aef46005 v0.8.5
diff --git a/Makefile.am b/Makefile.am
--- a/Makefile.am
+++ b/Makefile.am
@@ -17,7 +17,7 @@ ChangeLog :
.INTERMEDIATE: input.in.intermediate
input.in.intermediate: ${wisp_SOURCES}
- @abs_top_srcdir@/bootstrap.sh @abs_top_srcdir@ @guile@ @python3@ 2>&1 | sed "s/^;;;.*//" 2>&1 | grep . 1>&2 ; test ! $$? -eq 0 # grep did not find anything
+ @abs_top_srcdir@/bootstrap.sh @abs_top_srcdir@ @guile@ @python3@ 2>&1 | sed "s/^;;;.*//" 2>&1 | grep . 1>&2 ; test ! $$? -eq 0 # it worked if grep does not find anything
.PHONY: syntaxtests.sh
syntaxtests.sh : wisp.scm tests/runtests-scheme-preprocessor.sh
diff --git a/NEWS b/NEWS
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,8 @@
+wisp 0.8.5 (2015-07-28):
+- wisp-scheme.w now parses : . to nothing. The colon adds parens, the
+ dot removes them. This provides compatibility to the older parser.
+- wisp is now SRFI-119: http://srfi.schemers.org/srfi-119/srfi-119.html
+
wisp 0.8.4 (2015-06-23):
- no longer wrap wisp blocks into begin. Fixes missing macro
definitions when executed as file.
diff --git a/configure.ac b/configure.ac
--- a/configure.ac
+++ b/configure.ac
@@ -1,7 +1,7 @@
dnl run `autoreconf -i` to generate a configure script.
dnl Then run ./configure to generate a Makefile.
dnl Finally run make to generate the project.
-AC_INIT([wisp], [0.8.4],
+AC_INIT([wisp], [0.8.5],
[arne_bab@web.de])
# Check for programs I need for my build
AC_CANONICAL_TARGET
diff --git a/examples/cholesky.w b/examples/cholesky.w
new file mode 100644
--- /dev/null
+++ b/examples/cholesky.w
@@ -0,0 +1,46 @@
+#!/usr/bin/env sh
+# -*- wisp -*-
+exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples cholesky) main)' -s "$0" "$@"
+; !#
+
+;; Cholesky decomposition, following https://de.wikipedia.org/wiki/Cholesky-Zerlegung#Pseudocode
+
+define-module : examples cholesky
+ . #:exports : cholesky!
+
+use-modules : guildhall ext foof-loop
+
+define : matrrix-ref X u v
+ list-ref (list-ref X u) v
+
+define : matrrix-set! X u v val
+ list-set! (list-ref X u) v val
+
+
+define : cholesky! a
+ . "Modifies the square matirx a to contain its cholesky decomposition.
+
+sets a to g with a = ggT,
+
+a is represented as list of lists."
+ let : : n : length a
+ loop : : for i : up-from 1 : to n
+ loop : : for j : up-from 1 : to i
+ let : : sum : matrix-ref a i j
+ when : >= j 1
+ loop : : for k : up-from 1 : to {j - 1}
+ set! sum : - sum : * (matrix-ref a i k) (matrix-ref a j k)
+ cond
+ : > i j ; lower triangle
+ matrix-set! a i j
+ / sum : matrix-ref a j j
+ . a
+ : > sum 0 ; diagonal element
+ matrix-set! a i i : sqrt sum
+ . a
+ else
+ throw 'matrix-numerically-not-symmetric-positive-definite
+
+
+define : main args
+ display : cholesky! '((1 2)(2 4))
diff --git a/examples/closure.w b/examples/closure.w
new file mode 100644
--- /dev/null
+++ b/examples/closure.w
@@ -0,0 +1,26 @@
+#!/usr/bin/env sh
+# -*- wisp -*-
+exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples closure) main)' -s "$0" "$@"
+; !#
+
+;; A simple example for a closure
+
+
+define counting-closure ; simple variable
+ let : : counter 0 ; provide counter to hold local data
+ lambda () ; the variable is bound to a function -> callable
+ set! counter : 1+ counter ; adjust the counter shared by all function calls
+ . counter
+
+
+; counter is created outside the function definition (lambda), so the
+; change survives over function calls. It is function-local data.
+
+
+define : main args
+ display : counting-closure
+ newline ; 1
+ display : counting-closure
+ newline ; 2
+ display : counting-closure
+ newline ; 3
diff --git a/examples/evolve.w b/examples/evolve.w
old mode 100644
new mode 100755
--- a/examples/evolve.w
+++ b/examples/evolve.w
@@ -1,20 +1,38 @@
-#!/home/arne/wisp/wisp-multiline.sh
+#!/usr/bin/env sh
+# -*- wisp -*-
+exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples evolve) main)' -s "$0" "$@"
; !#
-; A small experiment on a complete evolutionary algorithm.
+; One thousand monkeys: A small experiment on a complete evolutionary algorithm.
+
+; TODO: genetic with mutate+combinate, population which keeps the best and directed which only keeps improvements
; NOTE: This only works after preprocessing to scheme.
+define-module : examples evolve
+ . #:export : main
+
; Get the eval string which allows for selecting the language.
use-modules : ice-9 eval-string
+define evalsyntax "0123456789+-*/: ()"
-define evalsyntax "0123456789+-*/ ()"
+
+define : paired-char? char
+ or (equal? #\) char) (equal? #\( char)
+
define : mutate-replace evalstring
- let
+ let*
: eval-index : random : string-length evalstring
replace-index : random : string-length evalsyntax
+ remove-char : string-ref evalstring eval-index
+ insert-char : string-ref evalsyntax replace-index
+ ; double step, if mutating a paired character
+ evalstring
+ if : not : or (paired-char? insert-char) (paired-char? remove-char)
+ . evalstring
+ mutate-replace evalstring
string-replace evalstring evalsyntax eval-index : + eval-index 1
. replace-index : + replace-index 1
@@ -28,29 +46,44 @@ define : mutate-permutate evalstring
define : mutate-insert evalstring
- let
+ let*
: eval-index : random : string-length evalstring
insert-index : random : string-length evalsyntax
+ insert-char : string-ref evalsyntax insert-index
+ ; double step, if mutating a paired character
+ evalstring
+ if : not : paired-char? insert-char
+ . evalstring
+ mutate-insert evalstring
string-append
substring evalstring 0 eval-index
- string : string-ref evalsyntax insert-index
+ string insert-char
substring evalstring eval-index
+define : mutate-remove-by-index evalstring index
+ string-append
+ substring evalstring 0 index
+ substring evalstring : + index 1
+
+
define : mutate-remove evalstring
if : <= 1 : string-length evalstring
; cannot remove from a 0 string
. evalstring
- let
+ let*
: eval-index : random : - (string-length evalstring) 1
- string-append
- substring evalstring 0 eval-index
- substring evalstring : + eval-index 1
-
+ eval-char : string-ref evalstring eval-index
+ ; double step, if mutating a paired character
+ evalstring
+ if : not : paired-char? eval-char
+ . evalstring
+ mutate-remove evalstring
+ mutate-remove-by-index evalstring eval-index
define : mutate-eval evalstring
eval-string : string-append "(" evalstring ")"
- . #:lang 'scheme
+ . #:lang 'scheme ; TODO: use wisp
define : better mutated original
@@ -85,23 +118,45 @@ define : evolve-remove evalstring
evolve-step evalstring mutate-remove
+define : evolution-step string
+ let : : action : random 4
+ cond
+ : = action 0
+ evolve-replace string
+ : = action 1
+ evolve-permutate string
+ : = action 2
+ evolve-insert string
+ : = action 3
+ evolve-remove string
+
+
+define : evolution-population initialstring steps population-size
+ . "a population with 50% survivors."
+ . initialstring
+
define : evolution initialstring steps
+ ; TODO: use
let loop : (step 0) (string initialstring)
- let : : action : random 4
- if : >= step steps
- . string
- cond
- : = action 0
- loop (+ step 1) (evolve-replace string)
- : = action 1
- loop (+ step 1) (evolve-permutate string)
- : = action 2
- loop (+ step 1) (evolve-insert string)
- : = action 3
- loop (+ step 1) (evolve-remove string)
+ if : >= step steps
+ . string
+ loop
+ 1+ step
+ evolution-step string
+
-define : run
+define : main args
; firstoff, seed the random number generator!
set! *random-state* : random-state-from-platform
- display : evolution "+ 1 (- 2 1)" 1000
- newline
+ let
+ : opt : evolution "+ 123 (- 2 1)" 1000
+ write opt
+ newline
+ write : mutate-eval opt
+ newline
+
+
+define : main
+ display "foo"
+ newline
+ run
diff --git a/examples/fizzbuzz.w b/examples/fizzbuzz.w
--- a/examples/fizzbuzz.w
+++ b/examples/fizzbuzz.w
@@ -9,16 +9,18 @@ define : divisible? number divisor
= 0 : remainder number divisor
define : fizzbuzz
- let : : print_number #f
- loop : : for i : up-from 1 : to 100
- set! print_number #t
- when : divisible? i 3
- display "Fizz"
- set! print_number #f
- when : divisible? i 5
- display "Buzz"
- set! print_number #f;
- when print_number : display i
- newline
+ let
+ : print_number #f
+ loop
+ : for i : up-from 1 : to 100
+ set! print_number #t
+ when : divisible? i 3
+ display "Fizz"
+ set! print_number #f
+ when : divisible? i 5
+ display "Buzz"
+ set! print_number #f;
+ when print_number : display i
+ newline
fizzbuzz
diff --git a/examples/hoist-in-loop.w b/examples/hoist-in-loop.w
new file mode 100644
--- /dev/null
+++ b/examples/hoist-in-loop.w
@@ -0,0 +1,105 @@
+;; This is partial example code taken from the loop optimization Guile code at
+;; http://git.savannah.gnu.org/gitweb/?p=guile.git;a=blob;f=module/language/cps/licm.scm;h=3b343a66bd8ed4a591a9e97edbf1179a4d3a78a8;hb=HEAD
+
+; I chose this example because this code felt very dense when I first
+; read it, so I wanted to check whether this improves with wisp
+; syntax.
+
+; but first the copyright information from the header of the file:
+
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015 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 : hoist-in-loop cps entry body-labels succs preds effects
+ let*
+ :
+ interior-succs
+ intmap-map
+ lambda : label succs
+ intset-intersect succs body-labels
+ . succs
+ sorted-labels : compute-reverse-post-order interior-succs entry
+ header-label : fresh-label
+ header-cont : intmap-ref cps entry
+ loop-vars
+ match header-cont
+ : $ $kargs names vars
+ list->intset vars
+ loop-effects
+ persistent-intmap
+ intset-fold
+ lambda : label loop-effects
+ let
+ :
+ label*
+ if : eqv? label entry
+ . header-label
+ . label
+ fx : intmap-ref effects label
+ intmap-add! loop-effects label* fx
+ body-labels empty-intmap
+ pre-header-label entry
+ pre-header-cont
+ match header-cont
+ : $ $kargs names vars term
+ let : : vars* : map (lambda (_) (fresh-var)) vars
+ build-cont
+ $kargs names vars*
+ $continue header-label #f
+ $values vars*
+ cps : intmap-add! cps header-label header-cont
+ cps : intmap-replace! cps pre-header-label pre-header-cont
+ to-visit
+ match sorted-labels
+ : head . tail
+ unless : eqv? head entry
+ error "what?"
+ cons header-label tail
+ define : rename-back-edges cont
+ define : rename label
+ if : eqv? label entry
+ . header-label
+ . label
+ rewrite-cont cont
+ : $ $kargs names vars : $ $continue kf src : $ $branch kt exp
+ $kargs names vars
+ $continue (rename kf) src : $branch (rename kt) ,exp
+ : $ $kargs names vars : $ $continue k src exp
+ $kargs names vars
+ $continue (rename k) src ,exp
+ : $ $kreceive ($ $arity req () rest) k
+ $kreceive req rest (rename k)
+ let lp
+ : cps cps
+ to-visit to-visit
+ loop-vars loop-vars
+ loop-effects loop-effects
+ pre-header-label pre-header-label
+ always-reached? #t
+ match to-visit
+ () cps
+ : label . to-visit
+ call-with-values
+ lambda :
+ hoist-one cps label (intmap-ref cps label) preds
+ . loop-vars loop-effects
+ . pre-header-label always-reached?
+ lambda : cps cont loop-vars loop-effects pre-header-label always-reached?
+ lp : intmap-replace! cps label : rename-back-edges cont
+ . to-visit
+ . loop-vars loop-effects pre-header-label always-reached?
diff --git a/examples/kit-encode.w b/examples/kit-encode.w
--- a/examples/kit-encode.w
+++ b/examples/kit-encode.w
@@ -1,6 +1,10 @@
-#!./wisp-multiline.sh
+#!/usr/bin/env sh
+# -*- wisp -*-
+exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples kit-encode) main)' -s "$0" "$@"
; !#
+define-module : examples kit-encode
+ . #:export : main kittify kittifylarge unkittify kittyfile kittytextfile unkittyfile unkittytextfile
use-modules
srfi srfi-1
rnrs io ports
@@ -257,55 +261,52 @@ define : unkittytextfile filepath
; displaywithnewline : kittyfile ".hg/store/00changelog.i"
; displaywithnewline : unkittytextfile "1.kit"
-; Now for the ultimate Kittyfication
-
-displaywithnewline "
- === TEXT MODE ==="
-
-displaywithnewline : kittify : map shiftbytedownfortext : bytevector->u8-list : string->utf8 "Karlsruhe Institut für Technologie (KIT)"
-
-displaywithnewline : utf8->string : u8-list->bytevector : map shiftbyteupfortext : unkittify "
- A.Y .p.i .q.p .s.e .b.3i.8.
- k.q .r. f.r. s.r. 3i.c.2A.
- 23.p .3 i.K.b._ .e.k .m.i
- .m.d .f .b.3i.3 r.A. 8.K.
-3s.. .... . .... .... ....
-.............. .... .... ....
-Karlsruher Institut fuer Technologie
-"
-
-
-displaywithnewline "
-
- === BINARY MODE ==="
-
-displaywithnewline : kittify : bytevector->u8-list : string->utf8 "Karlsruhe Institut für Technologie (KIT)"
-
-displaywithnewline : utf8->string : u8-list->bytevector : unkittify "
- 1F. 1c.1 u.1o .1v. 1u.1x.1j
- .1g .Y. 1D.1 q.1v .1w.1k.1
- w.1x .1 w.Y.1h. 3F.3 8.1u
- .Y.1 Q. 1g.1e.1 j.1q .1r.
-1o.1 r.1i . 1k.1 g.Y. f.1F
-.1D.1Q.g...... .... .... ....
-Karlsruher Institut fuer Technologie
-"
-
-
-displaywithnewline "
-
- === KIT, IMK, RemoteC ==="
-
-displaywithnewline : kittify : map shiftbytedownfortext : bytevector->u8-list : string->utf8 "Karlsruhe Institut für Technologie (KIT), IMK-ASF, RemoteC"
-
-
-displaywithnewline "
-
- === kittifyscript ==="
-
-displaywithnewline : kittytextfile "examples/kit-encode.w"
-
-
-
+define : main args
+ . "The ultimate Kittyfication"
+ displaywithnewline "
+ === TEXT MODE ==="
+
+ displaywithnewline : kittify : map shiftbytedownfortext : bytevector->u8-list : string->utf8 "Karlsruhe Institut für Technologie (KIT)"
+
+ displaywithnewline : utf8->string : u8-list->bytevector : map shiftbyteupfortext : unkittify "
+ A.Y .p.i .q.p .s.e .b.3i.8.
+ k.q .r. f.r. s.r. 3i.c.2A.
+ 23.p .3 i.K.b._ .e.k .m.i
+ .m.d .f .b.3i.3 r.A. 8.K.
+ 3s.. .... . .... .... ....
+ .............. .... .... ....
+ Karlsruher Institut fuer Technologie
+ "
+
+ displaywithnewline "
+
+ === BINARY MODE ==="
+
+ displaywithnewline : kittify : bytevector->u8-list : string->utf8 "Karlsruhe Institut für Technologie (KIT)"
+
+ displaywithnewline : utf8->string : u8-list->bytevector : unkittify "
+ 1F. 1c.1 u.1o .1v. 1u.1x.1j
+ .1g .Y. 1D.1 q.1v .1w.1k.1
+ w.1x .1 w.Y.1h. 3F.3 8.1u
+ .Y.1 Q. 1g.1e.1 j.1q .1r.
+ 1o.1 r.1i . 1k.1 g.Y. f.1F
+ .1D.1Q.g...... .... .... ....
+ Karlsruher Institut fuer Technologie
+ "
+
+ displaywithnewline "
+
+ === KIT, IMK, RemoteC ==="
+
+ displaywithnewline : kittify : map shiftbytedownfortext : bytevector->u8-list : string->utf8 "Karlsruhe Institut für Technologie (KIT), IMK-ASF, RemoteC"
+
+ displaywithnewline "
+
+ === kittifyscript ==="
+
+ displaywithnewline : kittytextfile "examples/kit-encode.w"
+
+
+
; TODO: Final step: Add commandline handling which allows to write into files and set the text flag and so on.
; ./kit-encode [-e|--encode|-d|--decode] [--text] [--template file] [--killstring "stringtoremove" (mutliple times)] [-o|--output file] [file|-]
diff --git a/wisp-scheme.w b/wisp-scheme.w
--- a/wisp-scheme.w
+++ b/wisp-scheme.w
@@ -371,6 +371,12 @@ define : line-code-replace-inline-colons
: 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
; FIXME: This should turn unprocessed into a list.