From saw at sandoak.co.uk  Thu Jul  1 15:10:41 2021
From: saw at sandoak.co.uk (Steve Woods)
Date: Thu, 1 Jul 2021 23:10:41 +0100
Subject: [CM] Building snd on a Mac
Message-ID: <9DBE2B0B-C5C6-4A5A-8E17-5B6CB9EEF362@sandoak.co.uk>

Hi

Just getting started and following the notes in README.snd I've built snd without errors but get the following error when it launches:

'Error: Couldn't find per display information'

Steps I've followed (Macbook Pro 2015, Catalina 10.15.7)

 XQuartz-2.8.1.dmg installer from www.xquartz.org
 xcode-select --install
 brew install gcc 
 brew install ruby
 brew install openmotif
 brew install poppler
 ./configure CFLAGS="-arch x86_64  -I/sw/include" LDFLAGS="-L/sw/lib -lmx -bind_at_load" --with-motif
 make

 ./snd
 > 'Error: Couldn't find per display information'

I've tried combinations of snd-21.4, snd-21.5,  XQuartz 2.7.11, XQuartz 2.8.1, XQuartz 2.7.8
and a different configuration from the README
./configure CFLAGS="-arch x86_64  -I/opt/X11/include" LDFLAGS="-L/opt/X11/lib -lmx -bind_at_load" --with-motif

I did have success with snd-20.7 (last version to support gtk) and ./configure --with-gtk

Seems to be a problem with motif and xquartz but I installed nedit (which uses motif) with homebrew and that works fine.

I see in the archives that Matti Koskinen successfully built snd-21 on Apple Mac Mini M1
https://cm-mail.stanford.edu/pipermail/cmdist/2021-April/008419.html

also some success in this thread
https://cm-mail.stanford.edu/pipermail/cmdist/2020-September/008108.html

What am I missing?
Has anybody experienced the 'Couldn't find per display information' error?
Feels like I'm almost there :)

Thanks

Steve


From bchristensen-lists at outlook.com  Sat Jul  3 13:32:05 2021
From: bchristensen-lists at outlook.com (Brad Christensen)
Date: Sat, 3 Jul 2021 20:32:05 +0000
Subject: [CM] s7 ((*repl* 'restore-repl)) breaks the repl
Message-ID: <SJ0PR02MB72133875DE70DC12D9C40462B81E9@SJ0PR02MB7213.namprd02.prod.outlook.com>

I've begun to explore the s7 repl via the manual. Testing a repl save and restore gave me a problem however:

```
$ s7i
s7: 6-Jul-2021
<1> (define (func n) 
? ? ? (+ n 1))
func
<2> (func 1)
2
<3> ((*repl* 'save-repl))
#<unspecified>
<4> (set! (*repl* 'top-level-let) (sublet (rootlet)))
(inlet)
<5> func
error: unbound variable func
<6> ((*repl* 'restore-repl))
func
<7> func
error: eval argument 2, func, is a function but should be a let (environment)
<8> (func 1)
error: eval argument 2, func, is a function but should be a let (environment)
<9> 42
error: eval argument 2, func, is a function but should be a let (environment)
<10> (*repl* 'top-level-let)
error: eval argument 2, func, is a function but should be a let (environment)
```

As an aside, another thing I noticed while looking at repl.scm was the `restore-repl` function does not take a filename argument, while the manual says it does.

Cheers, Brad


From bil at ccrma.Stanford.EDU  Sat Jul  3 13:54:33 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Sat, 03 Jul 2021 13:54:33 -0700
Subject: [CM] s7 ((*repl* 'restore-repl)) breaks the repl
In-Reply-To: <SJ0PR02MB72133875DE70DC12D9C40462B81E9@SJ0PR02MB7213.namprd02.prod.outlook.com>
References: <SJ0PR02MB72133875DE70DC12D9C40462B81E9@SJ0PR02MB7213.namprd02.prod.outlook.com>
Message-ID: <9b92887740bd9453ec73f55c1040cb95@ccrma.stanford.edu>

Thanks for the bug report.  restore-repl obviously wandered
out of sync with save-repl at some point.  I think this
will work:

       (define* (restore-repl (file "save.repl"))
	(set! (*repl* 'top-level-let) (sublet (rootlet)))
	(load file))



From j_hearon at hotmail.com  Sat Jul  3 17:47:11 2021
From: j_hearon at hotmail.com (James Hearon)
Date: Sun, 4 Jul 2021 00:47:11 +0000
Subject: [CM] loading libc_s7.so
Message-ID: <BYAPR10MB253698995B3AF4CDF33DE03DE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>

Hi,
I've been having a problem for a few builds with a non-gui build failing to load libc_s7.so.  When I run ./snd it writes libc_s7.so, but sticks on loading libc_s7.so.
Seems to work okay for gui build, --with-s7, --with-motif.  I don't do any make install.  Just make, then ./snd.

>ls -ld libc_s7.so
-rwxrwxr-x 1 jhearon jhearon 342000 Jul  3 14:29 libc_s7.so

but no joy getting ./snd to load it.

I'm wondering what might be the problem?

Regards,
Jim



[jhearon at localhost snd-21]$ ./configure  --with-s7 --with-gsl --with-alsa --without-gui CFLAGS=HAVE_COMPLEX_NUMBERS CFLAGS=HAVE_COMPLEX_TRIG
checking build system type... x86_64-pc-linux-gnu
checking host system type... x86_64-pc-linux-gnu
checking for gcc... gcc
checking whether the C compiler works... yes
checking for C compiler default output file name... a.out
checking for suffix of executables...
checking whether we are cross compiling... no
checking for suffix of object files... o
checking whether we are using the GNU C compiler... yes
checking whether gcc accepts -g... yes
checking for gcc option to accept ISO C89... none needed
checking for a BSD-compatible install... /usr/bin/install -c
checking how to run the C preprocessor... gcc -E
checking for grep that handles long lines and -e... /usr/bin/grep
checking for egrep... /usr/bin/grep -E
checking for ANSI C header files... yes
checking for sys/types.h... yes
checking for sys/stat.h... yes
checking for stdlib.h... yes
checking for string.h... yes
checking for memory.h... yes
checking for strings.h... yes
checking for inttypes.h... yes
checking for stdint.h... yes
checking for unistd.h... yes
checking whether byte ordering is bigendian... no
checking size of void *... 8
checking for pkg-config... /usr/bin/pkg-config
checking for fftw3... yes
checking for gsl... yes
checking for oggdec... no
checking for oggenc... no
checking for mpg123... /usr/bin/mpg123
checking for mpg321... no
checking for speexdec... no
checking for speexenc... no
checking for flac... no
checking for timidity... no
checking for wavpack... /usr/bin/wavpack
checking for wvunpack... /usr/bin/wvunpack
checking for audio system... ALSA
configure: creating ./config.status
config.status: creating makefile
config.status: creating mus-config.h

  Options selected
  -------------------------
  Snd version ...........: 21.6
  CFLAGS ................: -O2 -I. -I/usr/include/linux/param.h
  LDFLAGS ...............: -Wl,-export-dynamic
  LIBS...................:  -lm -ldl
  prefix.................: /usr/local
  extension language.....: s7
  audio system...........: ALSA
  graphics toolkit.......: None
  optional libraries.....: fftw-3.3.8 gsl-2.6
  random features........:
  environs...............: x86_64-pc-linux-gnu gcc
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210704/0a76072f/attachment.html>

From bil at ccrma.Stanford.EDU  Sun Jul  4 02:47:28 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Sun, 04 Jul 2021 02:47:28 -0700
Subject: [CM] =?utf-8?q?loading_libc=5Fs7=2Eso?=
In-Reply-To: <BYAPR10MB253698995B3AF4CDF33DE03DE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>
References: <BYAPR10MB253698995B3AF4CDF33DE03DE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>
Message-ID: <72ac655148cf4d51ad2991d3699990e9@ccrma.stanford.edu>

What is the error message?  I can't get anything to go wrong.



From j_hearon at hotmail.com  Sun Jul  4 10:22:10 2021
From: j_hearon at hotmail.com (James Hearon)
Date: Sun, 4 Jul 2021 17:22:10 +0000
Subject: [CM] loading libc_s7.so
Message-ID: <BYAPR10MB2536FB9C7F6292E30EB364EEE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>

Hi,
I don't receive an error message.  I just run
> ./snd
then the cursor just hangs on loading libc_s7.so and doesn't progress to <1>

I tried different configurations for building:
These work okay and load libc_s7.so:
$ ./configure --with-s7 --without-audio --without-gui
$ ./configure --with-s7 --without-audio --with-gui

But this one fails to load libc_s7.so
$ ./configure --with-s7 --with-alsa --without-gui

So am thinking maybe something with alsa?

My alsa:

/proc/asound/version
Advanced Linux Sound Architecture Driver Version k5.12.13-300.fc34.x86_64.

$ grep VERSION_STR /usr/include/alsa/version.h
#define SND_LIB_VERSION_STR "1.2.5.1"

Regards,
Jim
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210704/14556af8/attachment.html>

From bil at ccrma.Stanford.EDU  Sun Jul  4 12:04:22 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Sun, 04 Jul 2021 12:04:22 -0700
Subject: [CM] =?utf-8?q?loading_libc=5Fs7=2Eso?=
In-Reply-To: <BYAPR10MB2536FB9C7F6292E30EB364EEE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>
References: <BYAPR10MB2536FB9C7F6292E30EB364EEE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>
Message-ID: <dbaaf710ed1c496f67708a8c773a4b29@ccrma.stanford.edu>

Interesting -- I'm running versions 1.2.3 (Ubuntu) and
1.2.4, but when I upgraded to 1.2.5 in Fedora 34,
snd hangs while trying to set up the terminal for
direct (vt-100 style) use.  I wonder how ALSA could
affect that.  I notice online that ALSA version 1.2.5 has
many other problems, and people are downgrading
to 1.2.4.  strace can show you where it's stopping --
libc_s7.so has successfully loaded, and we're at the
(cursor-bounds) call around line 1140 in repl.scm.



From bil at ccrma.Stanford.EDU  Sun Jul  4 12:07:30 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Sun, 04 Jul 2021 12:07:30 -0700
Subject: [CM] =?utf-8?q?loading_libc=5Fs7=2Eso?=
In-Reply-To: <dbaaf710ed1c496f67708a8c773a4b29@ccrma.stanford.edu>
References: <BYAPR10MB2536FB9C7F6292E30EB364EEE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>
	<dbaaf710ed1c496f67708a8c773a4b29@ccrma.stanford.edu>
Message-ID: <63ea29e06022250d220eaf3905cd4792@ccrma.stanford.edu>

I forgot to say, you can use that version of Snd by
including -noinit:

./snd -noinit

but you're running the dumb repl.



From bil at ccrma.Stanford.EDU  Sun Jul  4 14:37:39 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Sun, 04 Jul 2021 14:37:39 -0700
Subject: [CM] =?utf-8?q?loading_libc=5Fs7=2Eso?=
In-Reply-To: <BYAPR10MB2536FB9C7F6292E30EB364EEE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>
References: <BYAPR10MB2536FB9C7F6292E30EB364EEE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>
Message-ID: <2a3fecdcc21cc5ba64ebe6ea309b23ba@ccrma.stanford.edu>

stdbuf -e0 ./snd

this seems to get the repl working but the initial cursor
is not displayed.  I don't know why stderr is buffered,
or how to do this in repl.scm.  nrepl.scm works without
needing stdbuf: configure Snd with the --with-notcurses
switch.  But (groan) notcurses does not work in Snd in
notcurses version 2.2 (2.3 has the bugfix, issue 1812).



From kennethflak at protonmail.com  Wed Jul  7 03:52:19 2021
From: kennethflak at protonmail.com (Kenneth Flak)
Date: Wed, 07 Jul 2021 10:52:19 +0000
Subject: [CM] snd/vim integration
Message-ID: <20210707105215.pepnprx46npnijo3@a15>

Hi list,

After years on the sidelines I decided to invest the necessary time to learn snd properly, and I have some ideas on how I could integrate it into my neovim workflow. Before I start reinventing the wheel though, I would just like to know if somebody has done any work on this before? I imagine using neovim to send chunks of code to snd via stdin, which seems to be a not too overwhelming task for a rookie programmer like myself... I would also be thrilled if there was a way to make the current keyboard shortcuts a bit more vim-like? Something akin to emacs evil mode, for example? My muscle memory is a bit lazy, and would prefer to stay in its hjkl pattern if possible.

All the best,
Kenneth

--
Roosna & Flak - Contemporary Dance & Music
Web: roosnaflak.com
Code: {github,gitlab}.com/kflak
Mastodon: @kf at sonomu.club




From bil at ccrma.Stanford.EDU  Wed Jul  7 07:22:32 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Wed, 07 Jul 2021 07:22:32 -0700
Subject: [CM] snd/vim integration
In-Reply-To: <20210707105215.pepnprx46npnijo3@a15>
References: <20210707105215.pepnprx46npnijo3@a15>
Message-ID: <fdbfaf178aa54bf128ef51b49373babd@ccrma.stanford.edu>

I don't know of any prior work on that.  snd-kbd.c has
the keyboard mappings.  There's an array "built-in-keys"
and a function "keyboard_command".  The latter is
a set of case statements -- it should be reasonably
obvious how it works.  I don't know anything about vim.
If you get something working, please let me know --
I'd be happy to merge it into my version.



From iainduncanlists at gmail.com  Wed Jul  7 08:08:19 2021
From: iainduncanlists at gmail.com (Iain Duncan)
Date: Wed, 7 Jul 2021 08:08:19 -0700
Subject: [CM] snd/vim integration
In-Reply-To: <fdbfaf178aa54bf128ef51b49373babd@ccrma.stanford.edu>
References: <20210707105215.pepnprx46npnijo3@a15>
	<fdbfaf178aa54bf128ef51b49373babd@ccrma.stanford.edu>
Message-ID: <CAN9NcLycZC3gYHUcpNVSPBfiwBTUsspsv38Jt8JdPg0P_8CDCw@mail.gmail.com>

Not sure if it's useful, but I can tell you how I wound up making my Vim to
Scheme-for-Max workflow:

- vim key mappings exist to visually select the current matching
parenthetical expression and send it to a Python script as stdin
- Python script sends to Max over OSC using liblo

The details are here:
https://github.com/iainctduncan/scheme-for-max-cookbook/blob/master/editor-integration/README.md


On Wed, Jul 7, 2021 at 7:22 AM <bil at ccrma.stanford.edu> wrote:

> I don't know of any prior work on that.  snd-kbd.c has
> the keyboard mappings.  There's an array "built-in-keys"
> and a function "keyboard_command".  The latter is
> a set of case statements -- it should be reasonably
> obvious how it works.  I don't know anything about vim.
> If you get something working, please let me know --
> I'd be happy to merge it into my version.
>
> _______________________________________________
> Cmdist mailing list
> Cmdist at ccrma.stanford.edu
> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210707/b2fdb204/attachment.html>

From bchristensen-lists at outlook.com  Wed Jul  7 08:10:29 2021
From: bchristensen-lists at outlook.com (Brad Christensen)
Date: Wed, 7 Jul 2021 15:10:29 +0000
Subject: [CM] Builds WITH_GMP Broken
Message-ID: <SJ0PR02MB7213F816CE35F8B0B6F41A1BB81A9@SJ0PR02MB7213.namprd02.prod.outlook.com>

Greetings,

It seems builds WITH_GMP have been broken since f77ba272 (July 4).

As an aside, is it preferred for s7 bug reports to hit this list or be sent directly to bil at ...?

Thanks, Brad


From kennethflak at protonmail.com  Wed Jul  7 08:21:23 2021
From: kennethflak at protonmail.com (Kenneth Flak)
Date: Wed, 07 Jul 2021 15:21:23 +0000
Subject: [CM] snd/vim integration
In-Reply-To: <CAN9NcLycZC3gYHUcpNVSPBfiwBTUsspsv38Jt8JdPg0P_8CDCw@mail.gmail.com>
References: <20210707105215.pepnprx46npnijo3@a15>
	<fdbfaf178aa54bf128ef51b49373babd@ccrma.stanford.edu>
	<CAN9NcLycZC3gYHUcpNVSPBfiwBTUsspsv38Jt8JdPg0P_8CDCw@mail.gmail.com>
Message-ID: <20210707152119.6wsvqvkz3xjwldk5@a15>

Thanks both!

I'll take a look at this once I finish a residency here in Tallinn next week. Very useful information. Haven't really done much in c, and I prefer to keep my vim python-free, but both of these angles should give me plenty of inspiration!

Best,
Kenneth

--
Roosna & Flak - Contemporary Dance & Music
Web: roosnaflak.com
Code: {github,gitlab}.com/kflak
Mastodon: @kf at sonomu.club
On  7 Jul 2021  08:08, Iain Duncan wrote:
>Not sure if it's useful, but I can tell you how I wound up making my Vim to
>Scheme-for-Max workflow:
>
>- vim key mappings exist to visually select the current matching parenthetical
>expression and send it to a Python script as stdin
>- Python script sends to Max over OSC using liblo?
>
>The details are here:?https://github.com/iainctduncan/scheme-for-max-cookbook/
>blob/master/editor-integration/README.md
>
>
>On Wed, Jul 7, 2021 at 7:22 AM <bil at ccrma.stanford.edu> wrote:
>
>    I don't know of any prior work on that.? snd-kbd.c has
>    the keyboard mappings.? There's an array "built-in-keys"
>    and a function "keyboard_command".? The latter is
>    a set of case statements -- it should be reasonably
>    obvious how it works.? I don't know anything about vim.
>    If you get something working, please let me know --
>    I'd be happy to merge it into my version.
>
>    _______________________________________________
>    Cmdist mailing list
>    Cmdist at ccrma.stanford.edu
>    https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>




From iainduncanlists at gmail.com  Wed Jul  7 08:25:05 2021
From: iainduncanlists at gmail.com (Iain Duncan)
Date: Wed, 7 Jul 2021 08:25:05 -0700
Subject: [CM] snd/vim integration
In-Reply-To: <20210707152119.6wsvqvkz3xjwldk5@a15>
References: <20210707105215.pepnprx46npnijo3@a15>
	<fdbfaf178aa54bf128ef51b49373babd@ccrma.stanford.edu>
	<CAN9NcLycZC3gYHUcpNVSPBfiwBTUsspsv38Jt8JdPg0P_8CDCw@mail.gmail.com>
	<20210707152119.6wsvqvkz3xjwldk5@a15>
Message-ID: <CAN9NcLycK3UmDDQh0gidcXaMjwho=-uOLHv-fby8_Ez6BgggeQ@mail.gmail.com>

I'm certainly interested to hear what you come up with too, my solution was
just the low hanging fruit I knew I could get working easily. Main thing
that might be useful from mine is just the mapping to get a visual
selection off to a command line script. That script could be anything that
hoovers up buffer contents over stdin.

iain

On Wed, Jul 7, 2021 at 8:21 AM Kenneth Flak <kennethflak at protonmail.com>
wrote:

> Thanks both!
>
> I'll take a look at this once I finish a residency here in Tallinn next
> week. Very useful information. Haven't really done much in c, and I prefer
> to keep my vim python-free, but both of these angles should give me plenty
> of inspiration!
>
> Best,
> Kenneth
>
> --
> Roosna & Flak - Contemporary Dance & Music
> Web: roosnaflak.com
> Code: {github,gitlab}.com/kflak
> Mastodon: @kf at sonomu.club
> On  7 Jul 2021  08:08, Iain Duncan wrote:
> >Not sure if it's useful, but I can tell you how I wound up making my Vim
> to
> >Scheme-for-Max workflow:
> >
> >- vim key mappings exist to visually select the current matching
> parenthetical
> >expression and send it to a Python script as stdin
> >- Python script sends to Max over OSC using liblo
> >
> >The details are here:
> https://github.com/iainctduncan/scheme-for-max-cookbook/
> >blob/master/editor-integration/README.md
> >
> >
> >On Wed, Jul 7, 2021 at 7:22 AM <bil at ccrma.stanford.edu> wrote:
> >
> >    I don't know of any prior work on that.  snd-kbd.c has
> >    the keyboard mappings.  There's an array "built-in-keys"
> >    and a function "keyboard_command".  The latter is
> >    a set of case statements -- it should be reasonably
> >    obvious how it works.  I don't know anything about vim.
> >    If you get something working, please let me know --
> >    I'd be happy to merge it into my version.
> >
> >    _______________________________________________
> >    Cmdist mailing list
> >    Cmdist at ccrma.stanford.edu
> >    https://cm-mail.stanford.edu/mailman/listinfo/cmdist
> >
>
>
> _______________________________________________
> Cmdist mailing list
> Cmdist at ccrma.stanford.edu
> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210707/53c1206a/attachment.html>

From bil at ccrma.Stanford.EDU  Wed Jul  7 09:47:47 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Wed, 07 Jul 2021 09:47:47 -0700
Subject: [CM] =?utf-8?q?Builds_WITH=5FGMP_Broken?=
In-Reply-To: <SJ0PR02MB7213F816CE35F8B0B6F41A1BB81A9@SJ0PR02MB7213.namprd02.prod.outlook.com>
References: <SJ0PR02MB7213F816CE35F8B0B6F41A1BB81A9@SJ0PR02MB7213.namprd02.prod.outlook.com>
Message-ID: <8204a1e36b00c9b82ff908ca2d6fbcb9@ccrma.stanford.edu>

Thanks for the heads-up!  A couple misplaced #endifs probably
when I was falling asleep.  I'll put up the fixed s7.c
tomorrow morning.

On the bug reports -- either way is fine with me -- I don't
know how others feel.



From iainduncanlists at gmail.com  Wed Jul  7 09:51:00 2021
From: iainduncanlists at gmail.com (Iain Duncan)
Date: Wed, 7 Jul 2021 09:51:00 -0700
Subject: [CM] Builds WITH_GMP Broken
In-Reply-To: <8204a1e36b00c9b82ff908ca2d6fbcb9@ccrma.stanford.edu>
References: <SJ0PR02MB7213F816CE35F8B0B6F41A1BB81A9@SJ0PR02MB7213.namprd02.prod.outlook.com>
	<8204a1e36b00c9b82ff908ca2d6fbcb9@ccrma.stanford.edu>
Message-ID: <CAN9NcLzYqUf=BYjX8Gurmn5wW_1hucriY8BTk80wKjnAbyVtyA@mail.gmail.com>

I find it helpful to see them here, and I think in general having them on
the public list is good because it demonstrates that there is active
development on s7 in a publicly searchable archive.

just my two cents from the sidelines!
iain

On Wed, Jul 7, 2021 at 9:48 AM <bil at ccrma.stanford.edu> wrote:

> Thanks for the heads-up!  A couple misplaced #endifs probably
> when I was falling asleep.  I'll put up the fixed s7.c
> tomorrow morning.
>
> On the bug reports -- either way is fine with me -- I don't
> know how others feel.
>
> _______________________________________________
> Cmdist mailing list
> Cmdist at ccrma.stanford.edu
> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210707/15a5070e/attachment.html>

From bil at ccrma.Stanford.EDU  Wed Jul  7 10:12:35 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Wed, 07 Jul 2021 10:12:35 -0700
Subject: [CM] =?utf-8?q?loading_libc=5Fs7=2Eso?=
In-Reply-To: <2a3fecdcc21cc5ba64ebe6ea309b23ba@ccrma.stanford.edu>
References: <BYAPR10MB2536FB9C7F6292E30EB364EEE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>
	<2a3fecdcc21cc5ba64ebe6ea309b23ba@ccrma.stanford.edu>
Message-ID: <0c9b60d36a2d2bf5acf59e79524d019c@ccrma.stanford.edu>

repl.scm now has a variable, stderr-buffered.  If the repl
hangs after printing "loading libc_so.so", set that variable
to #t.  I wonder who is messing with stderr -- pipewire?



From bchristensen-lists at outlook.com  Wed Jul  7 11:22:25 2021
From: bchristensen-lists at outlook.com (Brad Christensen)
Date: Wed, 7 Jul 2021 18:22:25 +0000
Subject: [CM] Builds WITH_GMP Broken
In-Reply-To: <CAN9NcLzYqUf=BYjX8Gurmn5wW_1hucriY8BTk80wKjnAbyVtyA@mail.gmail.com>
References: <SJ0PR02MB7213F816CE35F8B0B6F41A1BB81A9@SJ0PR02MB7213.namprd02.prod.outlook.com>
	<8204a1e36b00c9b82ff908ca2d6fbcb9@ccrma.stanford.edu>,
	<CAN9NcLzYqUf=BYjX8Gurmn5wW_1hucriY8BTk80wKjnAbyVtyA@mail.gmail.com>
Message-ID: <SJ0PR02MB72131325AF37B938473852AEB81A9@SJ0PR02MB7213.namprd02.prod.outlook.com>

I agree given there is no issue tracker currently utilized.
?
> I find it helpful to see them here, and I think in general having them on the public
> list is good because it demonstrates that there is active development on s7 in a
> publicly searchable archive.? 
> 
> just my two cents from the sidelines!
> iain



From j_hearon at hotmail.com  Wed Jul  7 11:52:42 2021
From: j_hearon at hotmail.com (James Hearon)
Date: Wed, 7 Jul 2021 18:52:42 +0000
Subject: [CM] loading libc_s7.c
Message-ID: <BYAPR10MB2536B529E198D861A0A2BA5CE51A9@BYAPR10MB2536.namprd10.prod.outlook.com>

Hi,
Thank you for the information.  The ./snd -noinit option seems to work best, so far for command-line approach.  My normal approach is to use snd thru emacs and I've not had the libc_s7 loading problem there.  So no worries, I can be patient until this gets sorted out.
Regards,
Jim


[jhearon at localhost snd-21]$ ./snd -noinit

> (new-sound "test.snd")
#<sound 0>
> (mix "oboe.snd")
#f
> (framples) 50828

;write argument 2, 50828, is an integer but should be an output port
;    (if (do ((p lst (cdr p))) ((not (and...
;    *stdout*, line 7, position: 789
; (if (do ((p lst (cdr p))) ((not (and (pai...


> (play)
#f
> (exit)
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210707/6006b6ca/attachment.html>

From tito.01beta at gmail.com  Thu Jul  8 00:42:55 2021
From: tito.01beta at gmail.com (Tito Latini)
Date: Thu, 8 Jul 2021 09:42:55 +0200
Subject: [CM] loading libc_s7.so
In-Reply-To: <0c9b60d36a2d2bf5acf59e79524d019c@ccrma.stanford.edu>
References: <BYAPR10MB2536FB9C7F6292E30EB364EEE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>
	<2a3fecdcc21cc5ba64ebe6ea309b23ba@ccrma.stanford.edu>
	<0c9b60d36a2d2bf5acf59e79524d019c@ccrma.stanford.edu>
Message-ID: <20210708074255.GA2702@vis.roboris>

> I wonder who is messing with stderr -- pipewire?

Probably yes. I can reproduce the problem after the change of alsa
settings for pipewire:

# snd 21.5, alsa-lib-1.2.5.1
./configure --without-gui

# no pipewire
./snd
loading libc_s7.so
<1>

New settings in ~/.asoundrc for pipewire (compiled from git 20210703):

pcm.pipewire { type pipewire }
ctl.pipewire { type pipewire }
pcm.!default pcm.pipewire
ctl.!default pcm.pipewire

# The repl hangs with or without pipewire daemon; the new alsa
# settings seem the problem.
./snd
loading libc_s7.so
Ctrl-c


From bil at ccrma.Stanford.EDU  Thu Jul  8 02:38:39 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Thu, 08 Jul 2021 02:38:39 -0700
Subject: [CM] =?utf-8?q?loading_libc=5Fs7=2Eso?=
In-Reply-To: <20210708074255.GA2702@vis.roboris>
References: <BYAPR10MB2536FB9C7F6292E30EB364EEE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>
	<2a3fecdcc21cc5ba64ebe6ea309b23ba@ccrma.stanford.edu>
	<0c9b60d36a2d2bf5acf59e79524d019c@ccrma.stanford.edu>
	<20210708074255.GA2702@vis.roboris>
Message-ID: <5cd153a475a3d44b39d55372adb40699@ccrma.stanford.edu>

Thanks very much!  Now I need to figure out how to register
a complaint.  Coffee first...




From chris.actondev at gmail.com  Thu Jul  8 02:58:19 2021
From: chris.actondev at gmail.com (Christos Vagias)
Date: Thu, 8 Jul 2021 11:58:19 +0200
Subject: [CM] loading libc_s7.so
In-Reply-To: <5cd153a475a3d44b39d55372adb40699@ccrma.stanford.edu>
References: <BYAPR10MB2536FB9C7F6292E30EB364EEE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>
	<2a3fecdcc21cc5ba64ebe6ea309b23ba@ccrma.stanford.edu>
	<0c9b60d36a2d2bf5acf59e79524d019c@ccrma.stanford.edu>
	<20210708074255.GA2702@vis.roboris>
	<5cd153a475a3d44b39d55372adb40699@ccrma.stanford.edu>
Message-ID: <CAG02pQhBOwvwkTTP-NwtYwM4xUwec7RG_S7tEnsm3wm60tM+bg@mail.gmail.com>

Hi all,
That complaint would have to go through
https://gitlab.freedesktop.org/pipewire/pipewire/-/issues I assume :)

And perhaps I should check pipewire as well, hope it's better than
going through the pulse & jack hoops

On Thu, 8 Jul 2021 at 11:38, <bil at ccrma.stanford.edu> wrote:
>
> Thanks very much!  Now I need to figure out how to register
> a complaint.  Coffee first...
>
>
> _______________________________________________
> Cmdist mailing list
> Cmdist at ccrma.stanford.edu
> https://cm-mail.stanford.edu/mailman/listinfo/cmdist


From kennethflak at protonmail.com  Thu Jul  8 03:16:04 2021
From: kennethflak at protonmail.com (Kenneth Flak)
Date: Thu, 08 Jul 2021 10:16:04 +0000
Subject: [CM] loading libc_s7.so
In-Reply-To: <CAG02pQhBOwvwkTTP-NwtYwM4xUwec7RG_S7tEnsm3wm60tM+bg@mail.gmail.com>
References: <BYAPR10MB2536FB9C7F6292E30EB364EEE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>
	<2a3fecdcc21cc5ba64ebe6ea309b23ba@ccrma.stanford.edu>
	<0c9b60d36a2d2bf5acf59e79524d019c@ccrma.stanford.edu>
	<20210708074255.GA2702@vis.roboris>
	<5cd153a475a3d44b39d55372adb40699@ccrma.stanford.edu>
	<CAG02pQhBOwvwkTTP-NwtYwM4xUwec7RG_S7tEnsm3wm60tM+bg@mail.gmail.com>
Message-ID: <20210708101559.x45ymipnyoifbbs2@a15>

Hi,

I wrote a blog post on transitioning to pipewire on Arch Linux a while ago: https://roosnaflak.com/tech-and-research/transitioning-to-pipewire/. You might find it useful.

In the meanwhile I went back to my old Pulse/Jack setup, as I couldn't quite get the same responsiveness from pipewire, but I found the developer incredibly responsive and committing stuff at a furious pace, so my guess is that pipewire will be a very good alternative to the present ecosystem in a short time. From the user point of view the experience is fantastic. Plug and play, soundcards just hotswapping when you plug them in and out, that sort of stuff... Feels almost like being back on mac, but then with much more extensibility.

Best,
Kenneth

--
Roosna & Flak - Contemporary Dance & Music
Web: roosnaflak.com
Code: {github,gitlab}.com/kflak
Mastodon: @kf at sonomu.club
On  8 Jul 2021  11:58, Christos Vagias wrote:
>Hi all,
>That complaint would have to go through
>https://gitlab.freedesktop.org/pipewire/pipewire/-/issues I assume :)
>
>And perhaps I should check pipewire as well, hope it's better than
>going through the pulse & jack hoops
>
>On Thu, 8 Jul 2021 at 11:38, <bil at ccrma.stanford.edu> wrote:
>>
>> Thanks very much!  Now I need to figure out how to register
>> a complaint.  Coffee first...
>>
>>
>> _______________________________________________
>> Cmdist mailing list
>> Cmdist at ccrma.stanford.edu
>> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>_______________________________________________
>Cmdist mailing list
>Cmdist at ccrma.stanford.edu
>https://cm-mail.stanford.edu/mailman/listinfo/cmdist




From chris.actondev at gmail.com  Thu Jul  8 03:34:22 2021
From: chris.actondev at gmail.com (Christos Vagias)
Date: Thu, 8 Jul 2021 12:34:22 +0200
Subject: [CM] loading libc_s7.so
In-Reply-To: <20210708101559.x45ymipnyoifbbs2@a15>
References: <BYAPR10MB2536FB9C7F6292E30EB364EEE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>
	<2a3fecdcc21cc5ba64ebe6ea309b23ba@ccrma.stanford.edu>
	<0c9b60d36a2d2bf5acf59e79524d019c@ccrma.stanford.edu>
	<20210708074255.GA2702@vis.roboris>
	<5cd153a475a3d44b39d55372adb40699@ccrma.stanford.edu>
	<CAG02pQhBOwvwkTTP-NwtYwM4xUwec7RG_S7tEnsm3wm60tM+bg@mail.gmail.com>
	<20210708101559.x45ymipnyoifbbs2@a15>
Message-ID: <CAG02pQg89L9jDNm0sPNq2p3Y640GsFGmy=p5-RkOaEewB8BFbA@mail.gmail.com>

Thanks Kenneth!

Another responsiveness-related tip would be to try a different kernel.
I did notice a BIG difference with liquorice kernel vs the generic
kernel (also a lot more responsive than the lowlatency kernel).
Haven't tried the "rt" kernel or any other one besides generic,
lowlatency & liquorice.

On Thu, 8 Jul 2021 at 12:16, Kenneth Flak <kennethflak at protonmail.com> wrote:
>
> Hi,
>
> I wrote a blog post on transitioning to pipewire on Arch Linux a while ago: https://roosnaflak.com/tech-and-research/transitioning-to-pipewire/. You might find it useful.
>
> In the meanwhile I went back to my old Pulse/Jack setup, as I couldn't quite get the same responsiveness from pipewire, but I found the developer incredibly responsive and committing stuff at a furious pace, so my guess is that pipewire will be a very good alternative to the present ecosystem in a short time. From the user point of view the experience is fantastic. Plug and play, soundcards just hotswapping when you plug them in and out, that sort of stuff... Feels almost like being back on mac, but then with much more extensibility.
>
> Best,
> Kenneth
>
> --
> Roosna & Flak - Contemporary Dance & Music
> Web: roosnaflak.com
> Code: {github,gitlab}.com/kflak
> Mastodon: @kf at sonomu.club
> On  8 Jul 2021  11:58, Christos Vagias wrote:
> >Hi all,
> >That complaint would have to go through
> >https://gitlab.freedesktop.org/pipewire/pipewire/-/issues I assume :)
> >
> >And perhaps I should check pipewire as well, hope it's better than
> >going through the pulse & jack hoops
> >
> >On Thu, 8 Jul 2021 at 11:38, <bil at ccrma.stanford.edu> wrote:
> >>
> >> Thanks very much!  Now I need to figure out how to register
> >> a complaint.  Coffee first...
> >>
> >>
> >> _______________________________________________
> >> Cmdist mailing list
> >> Cmdist at ccrma.stanford.edu
> >> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
> >_______________________________________________
> >Cmdist mailing list
> >Cmdist at ccrma.stanford.edu
> >https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>



From kennethflak at protonmail.com  Thu Jul  8 03:39:15 2021
From: kennethflak at protonmail.com (Kenneth Flak)
Date: Thu, 08 Jul 2021 10:39:15 +0000
Subject: [CM] loading libc_s7.so
In-Reply-To: <CAG02pQg89L9jDNm0sPNq2p3Y640GsFGmy=p5-RkOaEewB8BFbA@mail.gmail.com>
References: <BYAPR10MB2536FB9C7F6292E30EB364EEE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>
	<2a3fecdcc21cc5ba64ebe6ea309b23ba@ccrma.stanford.edu>
	<0c9b60d36a2d2bf5acf59e79524d019c@ccrma.stanford.edu>
	<20210708074255.GA2702@vis.roboris>
	<5cd153a475a3d44b39d55372adb40699@ccrma.stanford.edu>
	<CAG02pQhBOwvwkTTP-NwtYwM4xUwec7RG_S7tEnsm3wm60tM+bg@mail.gmail.com>
	<20210708101559.x45ymipnyoifbbs2@a15>
	<CAG02pQg89L9jDNm0sPNq2p3Y640GsFGmy=p5-RkOaEewB8BFbA@mail.gmail.com>
Message-ID: <20210708103910.k7ahdmlvwlg5f52y@a15>

I've always just used the rt kernel on Arch. Whenever I went back to vanilla, the xruns would pop up soon enough :-)

--
Roosna & Flak - Contemporary Dance & Music
Web: roosnaflak.com
Voice: +372 5565 1666
Code: {github,gitlab}.com/kflak
Mastodon: @kf at sonomu.club
On  8 Jul 2021  12:34, Christos Vagias wrote:
>Thanks Kenneth!
>
>Another responsiveness-related tip would be to try a different kernel.
>I did notice a BIG difference with liquorice kernel vs the generic
>kernel (also a lot more responsive than the lowlatency kernel).
>Haven't tried the "rt" kernel or any other one besides generic,
>lowlatency & liquorice.
>
>On Thu, 8 Jul 2021 at 12:16, Kenneth Flak <kennethflak at protonmail.com> wrote:
>>
>> Hi,
>>
>> I wrote a blog post on transitioning to pipewire on Arch Linux a while ago: https://roosnaflak.com/tech-and-research/transitioning-to-pipewire/. You might find it useful.
>>
>> In the meanwhile I went back to my old Pulse/Jack setup, as I couldn't quite get the same responsiveness from pipewire, but I found the developer incredibly responsive and committing stuff at a furious pace, so my guess is that pipewire will be a very good alternative to the present ecosystem in a short time. From the user point of view the experience is fantastic. Plug and play, soundcards just hotswapping when you plug them in and out, that sort of stuff... Feels almost like being back on mac, but then with much more extensibility.
>>
>> Best,
>> Kenneth
>>
>> --
>> Roosna & Flak - Contemporary Dance & Music
>> Web: roosnaflak.com
>> Code: {github,gitlab}.com/kflak
>> Mastodon: @kf at sonomu.club
>> On  8 Jul 2021  11:58, Christos Vagias wrote:
>> >Hi all,
>> >That complaint would have to go through
>> >https://gitlab.freedesktop.org/pipewire/pipewire/-/issues I assume :)
>> >
>> >And perhaps I should check pipewire as well, hope it's better than
>> >going through the pulse & jack hoops
>> >
>> >On Thu, 8 Jul 2021 at 11:38, <bil at ccrma.stanford.edu> wrote:
>> >>
>> >> Thanks very much!  Now I need to figure out how to register
>> >> a complaint.  Coffee first...
>> >>
>> >>
>> >> _______________________________________________
>> >> Cmdist mailing list
>> >> Cmdist at ccrma.stanford.edu
>> >> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>> >_______________________________________________
>> >Cmdist mailing list
>> >Cmdist at ccrma.stanford.edu
>> >https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>>




From bil at ccrma.Stanford.EDU  Thu Jul  8 06:09:37 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Thu, 08 Jul 2021 06:09:37 -0700
Subject: [CM] =?utf-8?q?loading_libc=5Fs7=2Eso?=
In-Reply-To: <CAG02pQhBOwvwkTTP-NwtYwM4xUwec7RG_S7tEnsm3wm60tM+bg@mail.gmail.com>
References: <BYAPR10MB2536FB9C7F6292E30EB364EEE51D9@BYAPR10MB2536.namprd10.prod.outlook.com>
	<2a3fecdcc21cc5ba64ebe6ea309b23ba@ccrma.stanford.edu>
	<0c9b60d36a2d2bf5acf59e79524d019c@ccrma.stanford.edu>
	<20210708074255.GA2702@vis.roboris>
	<5cd153a475a3d44b39d55372adb40699@ccrma.stanford.edu>
	<CAG02pQhBOwvwkTTP-NwtYwM4xUwec7RG_S7tEnsm3wm60tM+bg@mail.gmail.com>
Message-ID: <26cd0afe5721e0709420b9613793916f@ccrma.stanford.edu>

Thanks for the pointer!  It wasn't too bad -- had to register
with that gitlab so I could login, then create an issue --
much simpler than I feared!



From chris.actondev at gmail.com  Thu Jul  8 17:34:27 2021
From: chris.actondev at gmail.com (Christos Vagias)
Date: Fri, 9 Jul 2021 02:34:27 +0200
Subject: [CM] Weirdness with s7_load_c_string_with_environment, xxd fun
Message-ID: <CAG02pQjGg_ANk6+66=yr73L=cmcB5KgLYu-+hk_t+qcSSgKfbA@mail.gmail.com>

Hi Bil,

I'm getting some weird behavior with s7_load_c_string_with_environment.
I don't have a working example atm, it's late and just wanted to report this :)

Some description of what I'm doing:

calling s7_eval_c_string("(load \"main.scm\")");
and I have the load function replaced:

s7_define_function(sc, "load", load_with_resources, 1, 1, false,
                     "(load file (let (rootlet)))\n\
Tries to load \"file\" as an embedded resource first, and if it fails
it fallbacks to s7's load function");

And load_with_resources will either load a file from the memory (from
an included file produced with xxd -i) or try to actually load it from
the filesystem.

s7_pointer load_with_resources(s7_scheme *sc, s7_pointer args) {
  s7_pointer sc_file = s7_car(args);
  const char *file = s7_string(s7_car(args));
  s7_pointer env = s7_nil(sc);
  args = s7_cdr(args);
  if (args != s7_nil(sc))
    env = s7_car(args);

  Resource r = get_resource(sc, file);
  if (!r.data) {
    printf("Failed to load %s as embedded resource, trying normal
load\n", file);
    s7_pointer res = s7_load_with_environment(sc, file, env);
    // res might be null, should be careful to not return this
    // since this is an s7 binding
    if (!res) {
      return (s7_error(
          sc, s7_make_symbol(sc, "error"),
          s7_list(sc, 2, s7_make_string(sc, "load: can't open ~S"), sc_file)));
    }
    return res;
  }

  return s7_load_c_string_with_environment(sc, (char *)r.data, r.size,
                                           env);
}

And from the main.scm file, I'm loading other files:

(catch #t (lambda ()
                 (load "some-scheme-file.scm" some-env))
               (lambda (tag info) <print error> ))

And here is where I'm getting an error:
        unbound-variable
        unbound variable (symbol "\x94;\x10;")

When not replacing the "load" function (so that means loading the
files from the actual filesystem) all goes well. But, when loading the
files via the s7_load_c_string_with_environment
this error occurs.

If this is not helpful at all, I'll try to make some isolated demo
that demonstrates the problem.

Another note, s7_load_with_environment returns NULL if something goes
wrong, so returning
its result from an s7_function can lead to crashes. I know this is
documented but still seemed a bit weird for a behavior.

Best,
Christos


From chris.actondev at gmail.com  Fri Jul  9 05:50:26 2021
From: chris.actondev at gmail.com (Christos Vagias)
Date: Fri, 9 Jul 2021 14:50:26 +0200
Subject: [CM] Weirdness with s7_load_c_string_with_environment, xxd fun
In-Reply-To: <CAG02pQjGg_ANk6+66=yr73L=cmcB5KgLYu-+hk_t+qcSSgKfbA@mail.gmail.com>
References: <CAG02pQjGg_ANk6+66=yr73L=cmcB5KgLYu-+hk_t+qcSSgKfbA@mail.gmail.com>
Message-ID: <CAG02pQhpGEiuVtXJQ4-0Nr0XrfNeDAzYVXZ94YNNYhO00vxsRA@mail.gmail.com>

Hi Bil,

Was able to create a demo where this bug occurs
The readme.org contains the instructions for building this, and some notes

See attached file

On Fri, 9 Jul 2021 at 02:34, Christos Vagias <chris.actondev at gmail.com> wrote:
>
> Hi Bil,
>
> I'm getting some weird behavior with s7_load_c_string_with_environment.
> I don't have a working example atm, it's late and just wanted to report this :)
>
> Some description of what I'm doing:
>
> calling s7_eval_c_string("(load \"main.scm\")");
> and I have the load function replaced:
>
> s7_define_function(sc, "load", load_with_resources, 1, 1, false,
>                      "(load file (let (rootlet)))\n\
> Tries to load \"file\" as an embedded resource first, and if it fails
> it fallbacks to s7's load function");
>
> And load_with_resources will either load a file from the memory (from
> an included file produced with xxd -i) or try to actually load it from
> the filesystem.
>
> s7_pointer load_with_resources(s7_scheme *sc, s7_pointer args) {
>   s7_pointer sc_file = s7_car(args);
>   const char *file = s7_string(s7_car(args));
>   s7_pointer env = s7_nil(sc);
>   args = s7_cdr(args);
>   if (args != s7_nil(sc))
>     env = s7_car(args);
>
>   Resource r = get_resource(sc, file);
>   if (!r.data) {
>     printf("Failed to load %s as embedded resource, trying normal
> load\n", file);
>     s7_pointer res = s7_load_with_environment(sc, file, env);
>     // res might be null, should be careful to not return this
>     // since this is an s7 binding
>     if (!res) {
>       return (s7_error(
>           sc, s7_make_symbol(sc, "error"),
>           s7_list(sc, 2, s7_make_string(sc, "load: can't open ~S"), sc_file)));
>     }
>     return res;
>   }
>
>   return s7_load_c_string_with_environment(sc, (char *)r.data, r.size,
>                                            env);
> }
>
> And from the main.scm file, I'm loading other files:
>
> (catch #t (lambda ()
>                  (load "some-scheme-file.scm" some-env))
>                (lambda (tag info) <print error> ))
>
> And here is where I'm getting an error:
>         unbound-variable
>         unbound variable (symbol "\x94;\x10;")
>
> When not replacing the "load" function (so that means loading the
> files from the actual filesystem) all goes well. But, when loading the
> files via the s7_load_c_string_with_environment
> this error occurs.
>
> If this is not helpful at all, I'll try to make some isolated demo
> that demonstrates the problem.
>
> Another note, s7_load_with_environment returns NULL if something goes
> wrong, so returning
> its result from an s7_function can lead to crashes. I know this is
> documented but still seemed a bit weird for a behavior.
>
> Best,
> Christos
-------------- next part --------------
A non-text attachment was scrubbed...
Name: bug-2021-07-09-load_c_string.zip
Type: application/zip
Size: 4567 bytes
Desc: not available
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210709/763daa18/attachment.zip>

From bil at ccrma.Stanford.EDU  Fri Jul  9 06:35:22 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Fri, 09 Jul 2021 06:35:22 -0700
Subject: [CM]
 =?utf-8?q?Weirdness_with_s7=5Fload=5Fc=5Fstring=5Fwith=5Fenv?=
 =?utf-8?q?ironment=2C_xxd_fun?=
In-Reply-To: <CAG02pQhpGEiuVtXJQ4-0Nr0XrfNeDAzYVXZ94YNNYhO00vxsRA@mail.gmail.com>
References: <CAG02pQjGg_ANk6+66=yr73L=cmcB5KgLYu-+hk_t+qcSSgKfbA@mail.gmail.com>
	<CAG02pQhpGEiuVtXJQ4-0Nr0XrfNeDAzYVXZ94YNNYhO00vxsRA@mail.gmail.com>
Message-ID: <5252d436c3ca6673fec6c97e9d0c20a0@ccrma.stanford.edu>

Thanks for the example -- I had to add #include <string.
I get the error "string is not terminated".  xxd -i generates
an array that does not end with 0, so when it's cast to
a C string, it is not terminated.  The example scheme code
for make-repl-bits.scm adds that 0 at the end (see also
nrepl-bits.h).  If i add the ending 0's to the 2 resources
(leaving the length alone because it's viewed as a c string
length), your program appears to work.

/home/bil/test/bug1/ g++ -o m main.cpp -I. s7.o -lm -ldl
/home/bil/test/bug1/ m
here load_with_resources
Loading main.scm as embedded resource
here load_with_resources
Loading core.scm as embedded resource



From bil at ccrma.Stanford.EDU  Fri Jul  9 06:39:34 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Fri, 09 Jul 2021 06:39:34 -0700
Subject: [CM]
 =?utf-8?q?Weirdness_with_s7=5Fload=5Fc=5Fstring=5Fwith=5Fenv?=
 =?utf-8?q?ironment=2C_xxd_fun?=
In-Reply-To: <CAG02pQhpGEiuVtXJQ4-0Nr0XrfNeDAzYVXZ94YNNYhO00vxsRA@mail.gmail.com>
References: <CAG02pQjGg_ANk6+66=yr73L=cmcB5KgLYu-+hk_t+qcSSgKfbA@mail.gmail.com>
	<CAG02pQhpGEiuVtXJQ4-0Nr0XrfNeDAzYVXZ94YNNYhO00vxsRA@mail.gmail.com>
Message-ID: <0d294e2d88686824853631a2641d44fd@ccrma.stanford.edu>

It's unfortunate that C (as opposed to C++) does not let
you include a string, as opposed to an array of bytes.
Or something like that -- it was awhile ago and I'm
forgetting the distinction -- I vaguely remember that the
xxd trick was not necessary in C++.



From kennethflak at protonmail.com  Fri Jul  9 08:45:22 2021
From: kennethflak at protonmail.com (Kenneth Flak)
Date: Fri, 09 Jul 2021 15:45:22 +0000
Subject: [CM] Persistent configuration in snd?
Message-ID: <20210709154516.wx7n6km4pctik3fh@a15>

Hi list,

Working on getting to know snd a bit better, and ironing out a few wrinkles in how it behaves on a tiling wm (hint: set to floating, and make sure you are able to resize the window :-)), one thing keeps popping up: how do I add my own functions to ~/.snd_prefs_s7? As far as I can tell, the file is overwritten every time I change something in the configuration window or open a new file. I'd love to be able to set something simple like
; vim:set ft=scheme
at the bottom of it, so that vim will recognize the filetype and color it accordingly, as well as adding a few hooks..

Best,
Kenneth

--
Roosna & Flak - Contemporary Dance & Music
Web: roosnaflak.com
Voice: +372 5565 1666
Code: {github,gitlab}.com/kflak
Mastodon: @kf at sonomu.club




From bil at ccrma.Stanford.EDU  Fri Jul  9 09:46:32 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Fri, 09 Jul 2021 09:46:32 -0700
Subject: [CM] =?utf-8?q?Persistent_configuration_in_snd=3F?=
In-Reply-To: <20210709154516.wx7n6km4pctik3fh@a15>
References: <20210709154516.wx7n6km4pctik3fh@a15>
Message-ID: <8013937cf321f7f5bd48f8aa620b0825@ccrma.stanford.edu>

snd_prefs_s7 is written by the preferences dialog --
I don't think it is overwritten anywhere else.
The Snd initialization file is "~/snd_s7", described
in grfsnd.html; it is the place to add functions
you want every time you run Snd.  If you want to add
that line to snd_prefs_s7, look for save_prefs in
snd-prefs.c.



From kennethflak at protonmail.com  Fri Jul  9 11:09:09 2021
From: kennethflak at protonmail.com (Kenneth Flak)
Date: Fri, 09 Jul 2021 18:09:09 +0000
Subject: [CM] Persistent configuration in snd?
In-Reply-To: <8013937cf321f7f5bd48f8aa620b0825@ccrma.stanford.edu>
References: <20210709154516.wx7n6km4pctik3fh@a15>
	<8013937cf321f7f5bd48f8aa620b0825@ccrma.stanford.edu>
Message-ID: <vckIdMv3kfMdmijz6K7LA8gJ3Kc0Qk_N2xfVfN6E4SuYxZvXSb2-gKjWDE0ueW2-B5iuMlujsP6ISZcRvX2Lio214NhpNRFfO3ojIvw7KyM=@protonmail.com>

Great, thanks a lot!

Kenneth

Roosna & Flak - Contemporary Dance & Music

https://roosnaflak.com

On Fri, Jul 9, 2021 at 19:46, <bil at ccrma.Stanford.EDU> wrote:

> snd_prefs_s7 is written by the preferences dialog --
> I don't think it is overwritten anywhere else.
> The Snd initialization file is "~/snd_s7", described
> in grfsnd.html; it is the place to add functions
> you want every time you run Snd. If you want to add
> that line to snd_prefs_s7, look for save_prefs in
> snd-prefs.c.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210709/03e8e7ee/attachment.html>

From chris.actondev at gmail.com  Fri Jul  9 12:53:55 2021
From: chris.actondev at gmail.com (Christos Vagias)
Date: Fri, 9 Jul 2021 21:53:55 +0200
Subject: [CM] Weirdness with s7_load_c_string_with_environment, xxd fun
In-Reply-To: <0d294e2d88686824853631a2641d44fd@ccrma.stanford.edu>
References: <CAG02pQjGg_ANk6+66=yr73L=cmcB5KgLYu-+hk_t+qcSSgKfbA@mail.gmail.com>
	<CAG02pQhpGEiuVtXJQ4-0Nr0XrfNeDAzYVXZ94YNNYhO00vxsRA@mail.gmail.com>
	<0d294e2d88686824853631a2641d44fd@ccrma.stanford.edu>
Message-ID: <CAG02pQitckLcOVdunU+M29G040VXskCD+xPKAsVdVAxxbSXLfQ@mail.gmail.com>

Thanks Bil!

I thought that since you have to pass the string size, that'd be enough.
Tried to go through the code but didn't get far. I guess TOKEN_EOF
isn't emitted and the reader tries to read one more byte (garbage)?

The other issueI had found is if I pass s7_rootlet(sc); to the
s7_load_with_environment,
it crashes (segmentation fault). It happens also with the corrected
version (with the null
terminated string).

As for the xxd behavior & null terminated strings, I found a trick here:
https://stackoverflow.com/questions/410980/include-a-text-file-in-a-c-program-as-a-char#comment236032_411000

xxd -i < scheme_file.scm > scheme_file.xxd; echo ", 0x00" >>  scheme_file.xxd
and scheme_file.xxd will look like

  0x01, 0x02, 0xAA,.....
, 0x00

And then in code
  const char main_scm[] = {
#include "./resources/main_scm.xxd"
  };

Or, to just add that byte termination to existing xxd files:
sed -i -e 's/};/,0x00};/' ./resources/*scm.h
for the files produced by xxd

On Fri, 9 Jul 2021 at 15:39, <bil at ccrma.stanford.edu> wrote:
>
> It's unfortunate that C (as opposed to C++) does not let
> you include a string, as opposed to an array of bytes.
> Or something like that -- it was awhile ago and I'm
> forgetting the distinction -- I vaguely remember that the
> xxd trick was not necessary in C++.
>


From bil at ccrma.Stanford.EDU  Fri Jul  9 14:25:42 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Fri, 09 Jul 2021 14:25:42 -0700
Subject: [CM]
 =?utf-8?q?Weirdness_with_s7=5Fload=5Fc=5Fstring=5Fwith=5Fenv?=
 =?utf-8?q?ironment=2C_xxd_fun?=
In-Reply-To: <CAG02pQitckLcOVdunU+M29G040VXskCD+xPKAsVdVAxxbSXLfQ@mail.gmail.com>
References: <CAG02pQjGg_ANk6+66=yr73L=cmcB5KgLYu-+hk_t+qcSSgKfbA@mail.gmail.com>
	<CAG02pQhpGEiuVtXJQ4-0Nr0XrfNeDAzYVXZ94YNNYhO00vxsRA@mail.gmail.com>
	<0d294e2d88686824853631a2641d44fd@ccrma.stanford.edu>
	<CAG02pQitckLcOVdunU+M29G040VXskCD+xPKAsVdVAxxbSXLfQ@mail.gmail.com>
Message-ID: <3b707d513fafb0a2805546c731935ae8@ccrma.stanford.edu>

Thanks for the bug report -- I think I have fixed the code,
but (caught in other things) I haven't tested it yet --
surely by tomorrow.



From kennethflak at protonmail.com  Mon Jul 12 08:40:42 2021
From: kennethflak at protonmail.com (Kenneth Flak)
Date: Mon, 12 Jul 2021 15:40:42 +0000
Subject: [CM] Watchdog unable to set SCHED_RT priority
Message-ID: <20210712154038.gj5dtn63qeb7uvjv@a15>

Hi list,

I am getting this message when I exit snd:

```
SNDLIB: Unable to set SCHED_RR realtime priority for the watchdog thread. No watchdog.
SNDLIB: Watchdog exiting
```
Is this a point of worry? My user should have realtime priviliges on my arch linux box...

Best,
Kenneth

--
Roosna & Flak - Contemporary Dance & Music
Web: roosnaflak.com
Code: {github,gitlab}.com/kflak
Mastodon: @kf at sonomu.club




From k.s.matheussen at gmail.com  Mon Jul 12 15:22:37 2021
From: k.s.matheussen at gmail.com (Kjetil Matheussen)
Date: Tue, 13 Jul 2021 00:22:37 +0200
Subject: [CM] Watchdog unable to set SCHED_RT priority
In-Reply-To: <20210712154038.gj5dtn63qeb7uvjv@a15>
References: <20210712154038.gj5dtn63qeb7uvjv@a15>
Message-ID: <CAC6niELZ0zqB6b815miidXXh3cT6=7UrTKBV8hnHbuSTE3DCjQ@mail.gmail.com>

No worries probably. In practice it only means that the sound player
won't run with realtime priortiy (since it couldn't start the watchdog
thread). If you don't get any dropouts in sound then that's not a
problem. I guess you get that error because you don't have privilege
to start a SCHED_RR thread with the highest possible priority, but
again, if you don't hear any dropouts, then you don't need it. When I
wrote the code around 2003 it might have been necessary to run with
realtime priority, but today I guess it's not.


On Mon, Jul 12, 2021 at 5:44 PM Kenneth Flak <kennethflak at protonmail.com> wrote:
>
> Hi list,
>
> I am getting this message when I exit snd:
>
> ```
> SNDLIB: Unable to set SCHED_RR realtime priority for the watchdog thread. No watchdog.
> SNDLIB: Watchdog exiting
> ```
> Is this a point of worry? My user should have realtime priviliges on my arch linux box...
>
> Best,
> Kenneth
>
> --
> Roosna & Flak - Contemporary Dance & Music
> Web: roosnaflak.com
> Code: {github,gitlab}.com/kflak
> Mastodon: @kf at sonomu.club
>
>
> _______________________________________________
> Cmdist mailing list
> Cmdist at ccrma.stanford.edu
> https://cm-mail.stanford.edu/mailman/listinfo/cmdist


From kennethflak at protonmail.com  Mon Jul 12 22:40:33 2021
From: kennethflak at protonmail.com (Kenneth Flak)
Date: Tue, 13 Jul 2021 05:40:33 +0000
Subject: [CM] Watchdog unable to set SCHED_RT priority
In-Reply-To: <CAC6niELZ0zqB6b815miidXXh3cT6=7UrTKBV8hnHbuSTE3DCjQ@mail.gmail.com>
References: <20210712154038.gj5dtn63qeb7uvjv@a15>
	<CAC6niELZ0zqB6b815miidXXh3cT6=7UrTKBV8hnHbuSTE3DCjQ@mail.gmail.com>
Message-ID: <20210713054018.3whirtv4vvj5wykm@a15>

Thanks! That was my intuition as well... I'm running snd with a buffer size of 1024, without any dropouts so far. In any case I'm not using snd for realtime work, so this is not a problem area.

Best,
Kenneth

--
Roosna & Flak - Contemporary Dance & Music
Web: roosnaflak.com
Code: {github,gitlab}.com/kflak
Mastodon: @kf at sonomu.club
On 13 Jul 2021  00:22, Kjetil Matheussen wrote:
>No worries probably. In practice it only means that the sound player
>won't run with realtime priortiy (since it couldn't start the watchdog
>thread). If you don't get any dropouts in sound then that's not a
>problem. I guess you get that error because you don't have privilege
>to start a SCHED_RR thread with the highest possible priority, but
>again, if you don't hear any dropouts, then you don't need it. When I
>wrote the code around 2003 it might have been necessary to run with
>realtime priority, but today I guess it's not.
>
>
>On Mon, Jul 12, 2021 at 5:44 PM Kenneth Flak <kennethflak at protonmail.com> wrote:
>>
>> Hi list,
>>
>> I am getting this message when I exit snd:
>>
>> ```
>> SNDLIB: Unable to set SCHED_RR realtime priority for the watchdog thread. No watchdog.
>> SNDLIB: Watchdog exiting
>> ```
>> Is this a point of worry? My user should have realtime priviliges on my arch linux box...
>>
>> Best,
>> Kenneth
>>
>> --
>> Roosna & Flak - Contemporary Dance & Music
>> Web: roosnaflak.com
>> Code: {github,gitlab}.com/kflak
>> Mastodon: @kf at sonomu.club
>>
>>
>> _______________________________________________
>> Cmdist mailing list
>> Cmdist at ccrma.stanford.edu
>> https://cm-mail.stanford.edu/mailman/listinfo/cmdist




From kennethflak at protonmail.com  Tue Jul 13 01:52:59 2021
From: kennethflak at protonmail.com (Kenneth Flak)
Date: Tue, 13 Jul 2021 08:52:59 +0000
Subject: [CM] snd/vim integration
In-Reply-To: <CAN9NcLycK3UmDDQh0gidcXaMjwho=-uOLHv-fby8_Ez6BgggeQ@mail.gmail.com>
References: <20210707105215.pepnprx46npnijo3@a15>
	<fdbfaf178aa54bf128ef51b49373babd@ccrma.stanford.edu>
	<CAN9NcLycZC3gYHUcpNVSPBfiwBTUsspsv38Jt8JdPg0P_8CDCw@mail.gmail.com>
	<20210707152119.6wsvqvkz3xjwldk5@a15>
	<CAN9NcLycK3UmDDQh0gidcXaMjwho=-uOLHv-fby8_Ez6BgggeQ@mail.gmail.com>
Message-ID: <20210713085255.yfxpyzfwh4obaeof@a15>

Hi all,

I have found a very promising plugin for communicating between neovim and snd (only neovim, unfortunately, as it relies heavily on the lua api): https://github.com/Olical/conjure
The way I have set it up using packer is with this configuration:
```
         use {
             'Olical/conjure',
             config = function()
                 vim.g["conjure#client#scheme#stdio#command"] = "snd"
                 vim.g["conjure#client#scheme#stdio#prompt_pattern"] = ">"
             end
         }
```

If I now open a .scm file, an instance of snd is spawned, and I can send it commands directly from the nvim buffer by f.x. positioning the cursor over the sexpr I want to evaluate and hit <localleader>ee.

There seems to be some sort of auto-completion support, but I haven't had time to dig into this yet.

Best,
Kenneth

--
Roosna & Flak - Contemporary Dance & Music
Web: roosnaflak.com
Code: {github,gitlab}.com/kflak
Mastodon: @kf at sonomu.club
On  7 Jul 2021  08:25, Iain Duncan wrote:
>I'm certainly interested to hear what you come up with too, my solution was
>just the low hanging fruit I knew I could get working easily. Main thing that
>might be useful from mine is just the mapping to get a visual selection off to
>a command line script. That script could be anything that hoovers up buffer
>contents over stdin.
>
>iain
>
>On Wed, Jul 7, 2021 at 8:21 AM Kenneth Flak <kennethflak at protonmail.com> wrote:
>
>    Thanks both!
>
>    I'll take a look at this once I finish a residency here in Tallinn next
>    week. Very useful information. Haven't really done much in c, and I prefer
>    to keep my vim python-free, but both of these angles should give me plenty
>    of inspiration!
>
>    Best,
>    Kenneth
>
>    --
>    Roosna & Flak - Contemporary Dance & Music
>    Web: roosnaflak.com
>    Code: {github,gitlab}.com/kflak
>    Mastodon: @kf at sonomu.club
>    On? 7 Jul 2021? 08:08, Iain Duncan wrote:
>    >Not sure if it's useful, but I can tell you how I wound up making my Vim
>    to
>    >Scheme-for-Max workflow:
>    >
>    >- vim key mappings exist to visually select the current matching
>    parenthetical
>    >expression and send it to a Python script as stdin
>    >- Python script sends to Max over OSC using liblo?
>    >
>    >The details are here:?https://github.com/iainctduncan/
>    scheme-for-max-cookbook/
>    >blob/master/editor-integration/README.md
>    >
>    >
>    >On Wed, Jul 7, 2021 at 7:22 AM <bil at ccrma.stanford.edu> wrote:
>    >
>    >? ? I don't know of any prior work on that.? snd-kbd.c has
>    >? ? the keyboard mappings.? There's an array "built-in-keys"
>    >? ? and a function "keyboard_command".? The latter is
>    >? ? a set of case statements -- it should be reasonably
>    >? ? obvious how it works.? I don't know anything about vim.
>    >? ? If you get something working, please let me know --
>    >? ? I'd be happy to merge it into my version.
>    >
>    >? ? _______________________________________________
>    >? ? Cmdist mailing list
>    >? ? Cmdist at ccrma.stanford.edu
>    >? ? https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>    >
>
>
>    _______________________________________________
>    Cmdist mailing list
>    Cmdist at ccrma.stanford.edu
>    https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>




From k.s.matheussen at gmail.com  Tue Jul 13 10:57:38 2021
From: k.s.matheussen at gmail.com (Kjetil Matheussen)
Date: Tue, 13 Jul 2021 19:57:38 +0200
Subject: [CM] Watchdog unable to set SCHED_RT priority
In-Reply-To: <20210713054018.3whirtv4vvj5wykm@a15>
References: <20210712154038.gj5dtn63qeb7uvjv@a15>
	<CAC6niELZ0zqB6b815miidXXh3cT6=7UrTKBV8hnHbuSTE3DCjQ@mail.gmail.com>
	<20210713054018.3whirtv4vvj5wykm@a15>
Message-ID: <CAC6niEJW-0-3q6MVu=R0=f513RLTQSWtPx5tROh0KHAFX5S-TA@mail.gmail.com>

Hmm, I looked at the source code again, and it seems like the sound
player does run with realtime priority even when the watchdog can't
start. It's still not a problem though as modern computers usually
have more than one core plus that modern Linuxes should have a
built-in watchdog so that a single realtime thread shouldn't be able
to freeze the computer.

On Tue, Jul 13, 2021 at 7:40 AM Kenneth Flak <kennethflak at protonmail.com> wrote:
>
> Thanks! That was my intuition as well... I'm running snd with a buffer size of 1024, without any dropouts so far. In any case I'm not using snd for realtime work, so this is not a problem area.
>
> Best,
> Kenneth
>
> --
> Roosna & Flak - Contemporary Dance & Music
> Web: roosnaflak.com
> Code: {github,gitlab}.com/kflak
> Mastodon: @kf at sonomu.club
> On 13 Jul 2021  00:22, Kjetil Matheussen wrote:
> >No worries probably. In practice it only means that the sound player
> >won't run with realtime priortiy (since it couldn't start the watchdog
> >thread). If you don't get any dropouts in sound then that's not a
> >problem. I guess you get that error because you don't have privilege
> >to start a SCHED_RR thread with the highest possible priority, but
> >again, if you don't hear any dropouts, then you don't need it. When I
> >wrote the code around 2003 it might have been necessary to run with
> >realtime priority, but today I guess it's not.
> >
> >
> >On Mon, Jul 12, 2021 at 5:44 PM Kenneth Flak <kennethflak at protonmail.com> wrote:
> >>
> >> Hi list,
> >>
> >> I am getting this message when I exit snd:
> >>
> >> ```
> >> SNDLIB: Unable to set SCHED_RR realtime priority for the watchdog thread. No watchdog.
> >> SNDLIB: Watchdog exiting
> >> ```
> >> Is this a point of worry? My user should have realtime priviliges on my arch linux box...
> >>
> >> Best,
> >> Kenneth
> >>
> >> --
> >> Roosna & Flak - Contemporary Dance & Music
> >> Web: roosnaflak.com
> >> Code: {github,gitlab}.com/kflak
> >> Mastodon: @kf at sonomu.club
> >>
> >>
> >> _______________________________________________
> >> Cmdist mailing list
> >> Cmdist at ccrma.stanford.edu
> >> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>


From dev at mobileink.com  Thu Jul 15 05:06:11 2021
From: dev at mobileink.com (Gregg Reynolds)
Date: Thu, 15 Jul 2021 07:06:11 -0500
Subject: [CM] s7 issues?
Message-ID: <CAO40MikpTbS5pXgauV0r=Ei=h1_+yTf8ETfB9JBv=TpRGQHbfg@mail.gmail.com>

Hi,

I recently started using s7 to extend a C application. Looks really good
so far. Is this the place to report issues?

Specifically: (keyword? :a) and (symbol? :a) both report true.  Same if I
use (string->keyword "a") instead of litera :a.

FWIW I've written some demo code and a whole bunch of manpages if anybody
is interested. Also includes code to build the library using Bazel.
https://github.com/mobileink/s7

Thanks,

Gregg
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210715/61353afc/attachment.html>

From bil at ccrma.Stanford.EDU  Thu Jul 15 05:42:08 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Thu, 15 Jul 2021 05:42:08 -0700
Subject: [CM] =?utf-8?q?s7_issues=3F?=
In-Reply-To: <CAO40MikpTbS5pXgauV0r=Ei=h1_+yTf8ETfB9JBv=TpRGQHbfg@mail.gmail.com>
References: <CAO40MikpTbS5pXgauV0r=Ei=h1_+yTf8ETfB9JBv=TpRGQHbfg@mail.gmail.com>
Message-ID: <dc14ce08969af04ea90df584f433442f@ccrma.stanford.edu>

Hi!  You can report issues here, or to me personally.

In s7, keywords are symbols that happen to start or end
with a colon (and are constants evaluating to themselves).

Thanks very much for the link to your
docs and demos -- I'll check them out later today.
I don't think I've ever heard of Bazel.



From dev at mobileink.com  Thu Jul 15 06:54:27 2021
From: dev at mobileink.com (Gregg Reynolds)
Date: Thu, 15 Jul 2021 08:54:27 -0500
Subject: [CM] s7 issues?
In-Reply-To: <dc14ce08969af04ea90df584f433442f@ccrma.stanford.edu>
References: <CAO40MikpTbS5pXgauV0r=Ei=h1_+yTf8ETfB9JBv=TpRGQHbfg@mail.gmail.com>
	<dc14ce08969af04ea90df584f433442f@ccrma.stanford.edu>
Message-ID: <CAO40MimXG40A_KE5Jc86mYbCuh_51Nqs9hBiXdCwnHpTUBPCTA@mail.gmail.com>

Wow, that was quick!

On Thu, Jul 15, 2021 at 7:42 AM <bil at ccrma.stanford.edu> wrote:

> Hi!  You can report issues here, or to me personally.


> In s7, keywords are symbols that happen to start or end
> with a colon (and are constants evaluating to themselves).
>

My bad (I blame my fingers for all typing problems, haha..)


>
> Thanks very much for the link to your
> docs and demos -- I'll check them out later today.
> I don't think I've ever heard of Bazel.
>

It's the One True Build System.  (Joke!)  It's basically Google's internal
build system open-sourced. Very good for reproducible builds, polyglot
support, etc.  s7 doesn't really need a fancy build system, but if you want
to integrate it with other stuff, Bazel is nice to have.  You may find it
useful for development, play around with my docs&demos repo with it and let
me know if you have questions.

In fact the reason I got started with s7 is because I want to add a Scheme
binding to a Bazel tool I'm building.

s7 looks very good so far, really should be better known, maybe my demos
and docs can help with that.  Thanks so much for making it available!

I definitely have some questions and comments so I'll be in touch soon.

Gregg
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210715/8de95eb0/attachment.html>

From iainduncanlists at gmail.com  Thu Jul 15 07:33:11 2021
From: iainduncanlists at gmail.com (Iain Duncan)
Date: Thu, 15 Jul 2021 07:33:11 -0700
Subject: [CM] s7 issues?
In-Reply-To: <CAO40MimXG40A_KE5Jc86mYbCuh_51Nqs9hBiXdCwnHpTUBPCTA@mail.gmail.com>
References: <CAO40MikpTbS5pXgauV0r=Ei=h1_+yTf8ETfB9JBv=TpRGQHbfg@mail.gmail.com>
	<dc14ce08969af04ea90df584f433442f@ccrma.stanford.edu>
	<CAO40MimXG40A_KE5Jc86mYbCuh_51Nqs9hBiXdCwnHpTUBPCTA@mail.gmail.com>
Message-ID: <CAN9NcLw_-Rxq7sLm52S8dF2xAkC3MFn7F171Sqphx3c5Ci=p-w@mail.gmail.com>

Hi Gregg, that sounds really interesting. I look forward to checking out
Bazel at some point. Welcome to our small but enthusiastic crew of s7
hackers! It is indeed a lovely way to extend C applications. :-)

In case it's at all helpful for your manpages, I've written a crash course
in S7 for Scheme for Max users. If you ignore the Scheme for Max specific
bits (the "post" and "out" functions), it may be useful for some S7
examples. I plan on extending it with more pages on s7 specific features
too. It's here:
https://iainctduncan.github.io/learn-scheme-for-max/introduction.html

iain

On Thu, Jul 15, 2021 at 6:55 AM Gregg Reynolds <dev at mobileink.com> wrote:

> Wow, that was quick!
>
> On Thu, Jul 15, 2021 at 7:42 AM <bil at ccrma.stanford.edu> wrote:
>
>> Hi!  You can report issues here, or to me personally.
>
>
>> In s7, keywords are symbols that happen to start or end
>> with a colon (and are constants evaluating to themselves).
>>
>
> My bad (I blame my fingers for all typing problems, haha..)
>
>
>>
>> Thanks very much for the link to your
>> docs and demos -- I'll check them out later today.
>> I don't think I've ever heard of Bazel.
>>
>
> It's the One True Build System.  (Joke!)  It's basically Google's internal
> build system open-sourced. Very good for reproducible builds, polyglot
> support, etc.  s7 doesn't really need a fancy build system, but if you want
> to integrate it with other stuff, Bazel is nice to have.  You may find it
> useful for development, play around with my docs&demos repo with it and let
> me know if you have questions.
>
> In fact the reason I got started with s7 is because I want to add a Scheme
> binding to a Bazel tool I'm building.
>
> s7 looks very good so far, really should be better known, maybe my demos
> and docs can help with that.  Thanks so much for making it available!
>
> I definitely have some questions and comments so I'll be in touch soon.
>
> Gregg
> _______________________________________________
> Cmdist mailing list
> Cmdist at ccrma.stanford.edu
> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210715/318dbfd6/attachment.html>

From dev at mobileink.com  Thu Jul 15 08:01:03 2021
From: dev at mobileink.com (Gregg Reynolds)
Date: Thu, 15 Jul 2021 10:01:03 -0500
Subject: [CM] s7 issues?
In-Reply-To: <CAN9NcLw_-Rxq7sLm52S8dF2xAkC3MFn7F171Sqphx3c5Ci=p-w@mail.gmail.com>
References: <CAO40MikpTbS5pXgauV0r=Ei=h1_+yTf8ETfB9JBv=TpRGQHbfg@mail.gmail.com>
	<dc14ce08969af04ea90df584f433442f@ccrma.stanford.edu>
	<CAO40MimXG40A_KE5Jc86mYbCuh_51Nqs9hBiXdCwnHpTUBPCTA@mail.gmail.com>
	<CAN9NcLw_-Rxq7sLm52S8dF2xAkC3MFn7F171Sqphx3c5Ci=p-w@mail.gmail.com>
Message-ID: <CAO40Mimk4b1227vLgUV9JiuDUQ780hCog1CptAvigZt9J4VuFg@mail.gmail.com>

On Thu, Jul 15, 2021 at 9:33 AM Iain Duncan <iainduncanlists at gmail.com>
wrote:

> Hi Gregg, that sounds really interesting. I look forward to checking out
> Bazel at some point. Welcome to our small but enthusiastic crew of s7
> hackers! It is indeed a lovely way to extend C applications. :-)
>

Hello and thanks.

>
> In case it's at all helpful for your manpages, I've written a crash course
> in S7 for Scheme for Max users. If you ignore the Scheme for Max specific
> bits (the "post" and "out" functions), it may be useful for some S7
> examples. I plan on extending it with more pages on s7 specific features
> too. It's here:
> https://iainctduncan.github.io/learn-scheme-for-max/introduction.html
>

Haha, in fact I discovered s7 at
https://iainctduncan.github.io/scheme-for-max-docs/s7.html !  But I did not
know about your tutorial, I'll take a look.

Cheers,

Gregg
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210715/5a423543/attachment.html>

From iainduncanlists at gmail.com  Thu Jul 15 08:59:24 2021
From: iainduncanlists at gmail.com (Iain Duncan)
Date: Thu, 15 Jul 2021 08:59:24 -0700
Subject: [CM] s7 issues?
In-Reply-To: <CAO40Mimk4b1227vLgUV9JiuDUQ780hCog1CptAvigZt9J4VuFg@mail.gmail.com>
References: <CAO40MikpTbS5pXgauV0r=Ei=h1_+yTf8ETfB9JBv=TpRGQHbfg@mail.gmail.com>
	<dc14ce08969af04ea90df584f433442f@ccrma.stanford.edu>
	<CAO40MimXG40A_KE5Jc86mYbCuh_51Nqs9hBiXdCwnHpTUBPCTA@mail.gmail.com>
	<CAN9NcLw_-Rxq7sLm52S8dF2xAkC3MFn7F171Sqphx3c5Ci=p-w@mail.gmail.com>
	<CAO40Mimk4b1227vLgUV9JiuDUQ780hCog1CptAvigZt9J4VuFg@mail.gmail.com>
Message-ID: <CAN9NcLztnLiUcGmMDttYqG0RZPj9wjzZce3dtNPSRNAVxC2Yqg@mail.gmail.com>

Well that's nice to hear! I guess I need to add links between the various
documentation projects better though... :-)

Thanks Gregg!

On Thu, Jul 15, 2021 at 8:01 AM Gregg Reynolds <dev at mobileink.com> wrote:

>
>
> On Thu, Jul 15, 2021 at 9:33 AM Iain Duncan <iainduncanlists at gmail.com>
> wrote:
>
>> Hi Gregg, that sounds really interesting. I look forward to checking out
>> Bazel at some point. Welcome to our small but enthusiastic crew of s7
>> hackers! It is indeed a lovely way to extend C applications. :-)
>>
>
> Hello and thanks.
>
>>
>> In case it's at all helpful for your manpages, I've written a crash
>> course in S7 for Scheme for Max users. If you ignore the Scheme for Max
>> specific bits (the "post" and "out" functions), it may be useful for some
>> S7 examples. I plan on extending it with more pages on s7 specific features
>> too. It's here:
>> https://iainctduncan.github.io/learn-scheme-for-max/introduction.html
>>
>
> Haha, in fact I discovered s7 at
> https://iainctduncan.github.io/scheme-for-max-docs/s7.html !  But I did
> not know about your tutorial, I'll take a look.
>
> Cheers,
>
> Gregg
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210715/fa870795/attachment.html>

From dev at mobileink.com  Fri Jul 16 16:14:50 2021
From: dev at mobileink.com (Gregg Reynolds)
Date: Fri, 16 Jul 2021 18:14:50 -0500
Subject: [CM] s7 manpages & demos update
Message-ID: <CAO40MikMsweMV2N+jk1++QEaT=6=Ud_Zo-w_rTXRhWXwtrLmjQ@mail.gmail.com>

Hi folks,

FYI I've added a lot of material to the manpages.  The DESCRIPTION sections
are a little out of whack because I've reorganized a few of them, but the
SYNOPSIS sections contain a pretty substantial portion of the API - you may
find it useful even in its present inchoate state if you're coding to the
API.  (I find manpages the best way to quickly check APIs during
development...)

I've also added a zsh script in man/install.sh. If you clone the repo and
run the script, it will softlink the manpages to ${HOME}/man.  If
${HOME}/bin is on the PATH, then ${HOME}/man will automatically be added to
MANPATH, so you can do e.g. `$ man s7_c_object_value` etc.  At least that's
the way things work on MacOS; it shouldn't be too hard to adapt it to
Linux.  The script generates a link for each function in the API (at least
the ones that  are in the manpages.) - a whopping 360 links (but only 47
files so far).

I've also made substantial progress on a demo project, `demos/cstruct`.  It
covers most (some?) of the basics, I think.  With a little more work I
think it could form the basis of a pretty good project template.
Feedback/suggestions welcome.

The repo is at https://github.com/mobileink/s7

Cheers,

Gregg
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210716/c5a58386/attachment.html>

From treegestalt at gmail.com  Sat Jul 17 07:04:51 2021
From: treegestalt at gmail.com (Forrest Curo)
Date: Sat, 17 Jul 2021 07:04:51 -0700
Subject: [CM] s4pd (s7 for pd) with [text] perhaps for live-coding
Message-ID: <CAAn-EcyYkTQnJ7gSHWXVZZ863fbD53Tzu4_ipZg_RPJwiuqQ3A@mail.gmail.com>

[text define cod]
----------
[line 0(
| [step(
|/
[text sequence cod]
|
[send cud]
---------
[receive cud]
|
[list trim]             (This is needed with output from 'text')
|
[fudiform -u]
|
[list tosymbol]
|
[s4pd]
|
[print]
==========
Clicking on the [text define] box opens it for input, without having to go
into edit-mode. If you want what you type into it to remain stable, lines
should end with ';'

To make what you've just typed in to be visible to [s4pd] you need to save
it. Closing the box is one way, but cumbersome, and leaves it
inconveniently closed. So: ctrl-s does the job.
=========
Questions, by the way. Each [s4pd] runs its own separate line of
execution... Is there a built-in way for one [s4pd] to receive messages
from or share a variable with another? (I suppose they could both reference
the same pd [array]. Pd would be executing code from each box in sequence,
according to its signal flow?)
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210717/dee49ae2/attachment.html>

From dev at mobileink.com  Sat Jul 17 13:25:31 2021
From: dev at mobileink.com (Gregg Reynolds)
Date: Sat, 17 Jul 2021 15:25:31 -0500
Subject: [CM] bug in s7 keyword handling?
Message-ID: <CAO40Mi=cud1X_G2uXyM3RiV+XmWBFSBnmrOx+Scm7Nvm5hdpfQ@mail.gmail.com>

Hi,

There's no obvious cause of this in my code so I wonder what you make of it.

Background: my library is for parsing Starlark code (that's the language
Bazel uses). I'm using the object "applicator" capability to support
predicates and pseudo attributes, so I can do things like:

(node :<nodetype>?)

which returns true if the AST node has that type. E.g.  (node :list-expr?)

An example of a pseudo attribute is (node :@deps), which when applied to a
node of type :call-expr (that is, a Bazel rule application), reaches down
into the subnodes to get the "deps" attribute.  The Bazel code would look
like:

cc_library(
    name = "foobar",
    deps  = [":baz"]
)

So when applied to the cc_library node, it would return the nodelist for
"deps = [":baz"]".

It's been working great so far (just getting started) but I've run into the
following problem.  This works, returning true for the test node:

  (display (format #f "(node :stmt-list?): ~A" (node :stmt-list?)))

However, if I run it a second time, it fails.  The problem is that
s7_keyword_to_symbol strips the trailing question mark - but only the
second time thru!

Here's a fragment from my code:

    s7_pointer op = s7_car(rest);  /* op is the kw :stmt-list? */
    if (s7_is_keyword(op)) {
        log_debug("KWdump: %s", s7_object_to_c_string(s7, op));
        s7_pointer sym = s7_keyword_to_symbol(s7, op);
        log_debug("SYMdump: %s", s7_object_to_c_string(s7, sym));
        char *kw = (char*)s7_symbol_name(sym);
        log_debug("KW: %s", kw);
        ... handle kw ...
      ....

When I eval this:

  (display (format #f "(node :stmt-list?): ~A" (node :stmt-list?)))
(newline)
  (display (format #f "(node :stmt-list?): ~A" (node :stmt-list?)))
(newline)

This is the log output:

ast_node_s7.c:445: g_ast_node_object_applicator
ast_node_s7.c:1329: APPLICATOR ARGS:
ast_node_s7.c:1330: (:stmt-list?)
ast_node_s7.c:459: KWdump: :stmt-list?
ast_node_s7.c:461: SYMdump: stmt-list?   <<=========== ? retained
ast_node_s7.c:463: KW: stmt-list?
ast_node_s7.c:479: KW PREDICATE stmt-list?
ast_node_s7.c:338: ast_node_type_kw_pred: stmt-list?
nodes.c:317: lookup: TK-Stmt-List
(node :stmt-list?): #t
ast_node_s7.c:445: g_ast_node_object_applicator
ast_node_s7.c:1329: APPLICATOR ARGS:
ast_node_s7.c:1330: (:stmt-list?)
ast_node_s7.c:459: KWdump: :stmt-list?
ast_node_s7.c:461: SYMdump: stmt-list          <<======= ? disappeared
ast_node_s7.c:463: KW: stmt-list
ast_node_s7.c:385: g_ast_node_ref_specialized
ast_node_s7.c:289: ast_node_property_lookup

;ast-node-ref argument 1, :stmt-list?, is a symbol but should be one of :c,
:str, :i, etc.

(The error is correct since the actual lookup is based on stmt-list not
stmt-list?)

It looks to me like it might be a bug in s7, but I would not be surprised
if my code has managed to corrupt the memory somehow.  Any help would be
appreciated.

Gregg
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210717/1f2dfd55/attachment.html>

From dev at mobileink.com  Sat Jul 17 13:49:53 2021
From: dev at mobileink.com (Gregg Reynolds)
Date: Sat, 17 Jul 2021 15:49:53 -0500
Subject: [CM] disregard prev msg
Message-ID: <CAO40MinQGwsj=PMUeW+oR6OMJV7DdkOGjcXZWnncotS=Yq8a1w@mail.gmail.com>

Naturally I found the bug in my code a few minutes after sending a "bug"
report. Funny how often that happens....

Sorry about the noise,

Gregg
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210717/1d08cbb3/attachment.html>

From elronnd at elronnd.net  Sat Jul 17 17:56:59 2021
From: elronnd at elronnd.net (Elijah Stone)
Date: Sat, 17 Jul 2021 17:56:59 -0700 (PDT)
Subject: [CM] Navigation in nrepl
Message-ID: <ea8c383b-a2d8-63a0-82c7-5e10d61cc368@elronnd.net>

Nrepl is really great, but I've found myself missing wordwise navigation 
and deletion.  So, the attached patch to nrepl.scm implements C-w, M-d, 
C-u, M-b, M-f a la readline (except with more relaxed word separators as 
befits lisp).  It also changes meta-key recognition to recognise 'alt' as 
a meta key.

Cheers,

  -E
-------------- next part --------------
975,976c975,979
< 		      (selection #f)
< 		      (control-key (ash 1 33)))    ; notcurses getc returns 32 bits
---
> 		      (selection "")
>                       (previously-selected #f)
>                       (just-selected #f)
> 		      (control-key (ash 1 33))
>                       (meta-key (ash 1 34)))    ; notcurses getc returns 32 bits
1157,1217c1160,1276
< 		  (set! (keymap (char->integer #\escape))
< 			(lambda (c)
< 			  ;; these are the Meta key handlers
< 			  (let ((k (notcurses_getc nc (c-pointer 0) (c-pointer 0) ni)))
< 
< 			    (case (integer->char k)
< 			      ((#\C #\c)
< 			       (do ((len (- (eols row) col))
< 				    (cur-line (ncplane_contents ncp row col 1 (- (eols row) col)))
< 				    (i 0 (+ i 1)))
< 				   ((or (= i len)
< 					(char-alphabetic? (cur-line i)))
< 				    (when (< i len)
< 				      (set! (cur-line i) (char-upcase (cur-line i)))
< 				      (nc-display row col cur-line)
< 				      (notcurses_refresh nc)
< 				      (do ((k (+ i 1) (+ k 1)))
< 					  ((or (>= k len)
< 					       (not (or (char-alphabetic? (cur-line k))
< 							(char-numeric? (cur-line k)))))
< 					   (set! col (min (eols row) (+ col k)))))))))
< 
< 			      ((#\L #\l)
< 			       (do ((len (- (eols row) col))
< 				    (cur-line (ncplane_contents ncp row col 1 (- (eols row) col)))
< 				    (i 0 (+ i 1)))
< 				   ((or (= i len)
< 					(char-alphabetic? (cur-line i)))
< 				    (when (< i len)
< 				      (do ((k i (+ k 1)))
< 					  ((or (= k len)
< 					       (not (char-alphabetic? (cur-line k))))
< 					   (nc-display row col cur-line)
< 					   (notcurses_refresh nc)
< 					   (set! col (+ col k)))
< 					(set! (cur-line k) (char-downcase (cur-line k))))))))
< 
< 			      ((#\U #\u)
< 			       (do ((len (- (eols row) col))
< 				    (cur-line (ncplane_contents ncp row col 1 (- (eols row) col)))
< 				    (i 0 (+ i 1)))
< 				   ((or (= i len)
< 					(char-alphabetic? (cur-line i)))
< 				    (when (< i len)
< 				      (do ((k i (+ k 1)))
< 					  ((or (= k len)
< 					       (not (char-alphabetic? (cur-line k))))
< 					   (nc-display row col cur-line)
< 					   (notcurses_refresh nc)
< 					   (set! col (+ col k)))
< 					(set! (cur-line k) (char-upcase (cur-line k))))))))
< 
< 			      ((#\<)
< 			       (set-row 0)
< 			       (set-col (bols 0)))
< 
< 			      ((#\>)
< 			       (set-row ncp-max-row)
< 			       (set-col (bols ncp-max-row)))
< 
< 			      )))) ; end Meta keys
---
>                   (define (prepend-to-selection new-text)
>                     (unless (zero? (length new-text))
>                       (set! selection (if previously-selected (append new-text selection)
>                                         new-text))
>                       (set! just-selected #t)))
>                   (define (append-to-selection new-text)
>                     (unless (zero? (length new-text))
>                       (set! selection (if previously-selected (append selection new-text)
>                                         new-text))
>                       (set! just-selected #t)))
>                   (define (char-alphanumeric? c)
>                     (or (char-alphabetic? c)
>                         (char-numeric? c)))
>                   (define (word-back-x)
>                     (let loop ((col (max (bols row) (- col 1))))
>                       (if (= col (bols row))
>                         col
>                         (if (string=? " " (ncplane_contents ncp row col 1 1))
>                           (loop (- col 1))
>                           (let loop ((col col))
>                             (if (= col (bols row))
>                               col
>                               (if (string=? " " (ncplane_contents ncp row (- col 1) 1 1))
>                                 col
>                                 (loop (- col 1)))))))))
>                   (define (word-forward-x)
>                     (let loop ((col (min (eols row) (+ col 1))))
>                       (if (= col (eols row))
>                         col
>                         (if (string=? " " (ncplane_contents ncp row col 1 1))
>                           (loop (+ col 1))
>                           (let loop ((col col))
>                             (if (= col (eols row))
>                               col
>                               (if (string=? " " (ncplane_contents ncp row col 1 1))
>                                 col
>                                 (loop (+ col 1)))))))))
> 
>                   (set! (keymap (+ meta-key (char->integer #\B)))
>                     (set! (keymap (+ meta-key (char->integer #\b)))
>                       (lambda (c)
>                         (set! col (word-back-x)))))
> 
>                   (set! (keymap (+ meta-key (char->integer #\C)))
>                     (set! (keymap (+ meta-key (char->integer #\c)))
>                       (lambda (c)
>                         (do ((len (- (eols row) col))
>                              (cur-line (ncplane_contents ncp row col 1 (- (eols row) col)))
>                              (i 0 (+ i 1)))
>                           ((or (= i len)
>                                (char-alphabetic? (cur-line i)))
>                            (when (< i len)
>                              (set! (cur-line i) (char-upcase (cur-line i)))
>                              (nc-display row col cur-line)
>                              (notcurses_refresh nc)
>                              (do ((k (+ i 1) (+ k 1)))
>                                ((or (>= k len)
>                                     (not (char-alphanumeric? (cur-line k))))
>                                 (set! col (min (eols row) (+ col k)))))))))))
> 
>                   (set! (keymap (+ meta-key (char->integer #\D)))
>                     (set! (keymap (+ meta-key (char->integer #\d)))
>                       (lambda (c)
>                         (let ((newcol (word-forward-x)))
>                           (append-to-selection (ncplane_contents ncp row col 1 (- newcol col)))
>                           (nc-display row col (ncplane_contents ncp row newcol 1 (- (eols row) newcol)))
>                           (nc-display row (- (eols row) (- newcol col)) (make-string (- newcol col) #\space))
>                           (set! (eols row) (- (eols row) (- newcol col)))))))
> 
>                   (set! (keymap (+ meta-key (char->integer #\F)))
>                     (set! (keymap (+ meta-key (char->integer #\f)))
>                       (lambda (c)
>                         (set! col (word-forward-x)))))
> 
>                   (set! (keymap (+ meta-key (char->integer #\L)))
>                     (set! (keymap (+ meta-key (char->integer #\l)))
>                       (lambda (c)
>                         (do ((len (- (eols row) col))
>                              (cur-line (ncplane_contents ncp row col 1 (- (eols row) col)))
>                              (i 0 (+ i 1)))
>                           ((or (= i len)
>                                (char-alphabetic? (cur-line i)))
>                            (when (< i len)
>                              (do ((k i (+ k 1)))
>                                ((or (= k len)
>                                     (not (char-alphabetic? (cur-line k))))
>                                 (nc-display row col cur-line)
>                                 (notcurses_refresh nc)
>                                 (set! col (+ col k)))
>                                (set! (cur-line k) (char-downcase (cur-line k))))))))))
> 
>                   (set! (keymap (+ meta-key (char->integer #\U)))
>                     (set! (keymap (+ meta-key (char->integer #\u)))
>                       (lambda (c)
>                         (do ((len (- (eols row) col))
>                              (cur-line (ncplane_contents ncp row col 1 (- (eols row) col)))
>                              (i 0 (+ i 1)))
>                           ((or (= i len)
>                                (char-alphabetic? (cur-line i)))
>                            (when (< i len)
>                              (do ((k i (+ k 1)))
>                                ((or (= k len)
>                                     (not (char-alphabetic? (cur-line k))))
>                                 (nc-display row col cur-line)
>                                 (notcurses_refresh nc)
>                                 (set! col (+ col k)))
>                                (set! (cur-line k) (char-upcase (cur-line k))))))))))
> 
>                   (set! (keymap (+ meta-key (char->integer #\<)))
>                     (lambda (c)
>                       (set-row 0)
>                       (set-col (bols 0))))
> 
>                   (set! (keymap (+ meta-key (char->integer #\>)))
>                     (lambda (c)
>                       (set-row ncp-max-row)
>                       (set-col (bols ncp-max-row))))
1268,1272c1327,1331
< 		  (set! (keymap (+ control-key (char->integer #\K)))
< 			(lambda (c)
< 			  (set! selection (ncplane_contents ncp row col 1 (- (eols row) col)))
< 			  (nc-display row col (make-string (- (eols row) col) #\space))
< 			  (set! (eols row) col)))
---
>                   (set! (keymap (+ control-key (char->integer #\K)))
>                     (lambda (c)
>                       (append-to-selection (ncplane_contents ncp row col 1 (- (eols row) col)))
>                       (nc-display row col (make-string (- (eols row) col) #\space))
>                       (set! (eols row) col)))
1340a1400,1416
>                   (set! (keymap (+ control-key (char->integer #\U)))
>                     (lambda (c)
>                       (prepend-to-selection (ncplane_contents ncp row (bols row) 1 (- col (bols row))))
>                       (nc-display row (bols row) (ncplane_contents ncp row col 1 (- (eols row) col)))
>                       (nc-display row (- (eols row) (- col (bols row))) (make-string (- col (bols row)) #\space))
>                       (set! (eols row) (- (eols row) (- col (bols row))))
>                       (set! col (bols row))))
> 
>                   (set! (keymap (+ control-key (char->integer #\W)))
>                     (lambda (c)
>                       (let ((newcol (word-back-x)))
>                         (prepend-to-selection (ncplane_contents ncp row newcol 1 (- col newcol)))
>                         (nc-display row newcol (ncplane_contents ncp row col 1 (- (eols row) col)))
>                         (nc-display row (- (eols row) (- col newcol)) (make-string (- col newcol) #\space))
>                         (set! (eols row) (- (eols row) (- col newcol)))
>                         (set! col newcol))))
> 
1353c1429
< 			    (set-col (eols row)))))
---
> 			    (set-col (+ col (length selection))))))
1474a1551,1553
>                           (set! previously-selected just-selected)
>                           (set! just-selected #f)
> 
1476c1555,1559
< 				 (func (hash-table-ref keymap (if (ncinput_ctrl ni) (+ c control-key) c))))
---
>                                  (c (if (= c (char->integer #\escape))
>                                       (logior meta-key (notcurses_getc nc (c-pointer 0) (c-pointer 0) ni))
>                                       c))
> 				 (func (hash-table-ref keymap (logior c (if (ncinput_ctrl ni) control-key 0)
>                                                                         (if (ncinput_alt ni) meta-key 0)))))

From elronnd at elronnd.net  Sat Jul 17 18:00:15 2021
From: elronnd at elronnd.net (Elijah Stone)
Date: Sat, 17 Jul 2021 18:00:15 -0700 (PDT)
Subject: [CM] Navigation in nrepl
In-Reply-To: <ea8c383b-a2d8-63a0-82c7-5e10d61cc368@elronnd.net>
References: <ea8c383b-a2d8-63a0-82c7-5e10d61cc368@elronnd.net>
Message-ID: <e1383451-4c9e-a43d-22f5-74617762e86a@elronnd.net>

> attached patch

Sorry, that was an older version; revised is attached.
-------------- next part --------------
diff --git a/nrepl.scm b/nrepl.scm
index aaf7515..eae5f11 100644
--- a/nrepl.scm
+++ b/nrepl.scm
@@ -972,8 +972,11 @@
 		      (mouse-col #f)
 		      (mouse-row #f)
 		      (repl-done #f)
-		      (selection #f)
-		      (control-key (ash 1 33)))    ; notcurses getc returns 32 bits
+		      (selection "")
+                      (previously-selected #f)
+                      (just-selected #f)
+		      (control-key (ash 1 33))
+                      (meta-key (ash 1 34)))    ; notcurses getc returns 32 bits
 
 		  (set! (top-level-let 'ncp-let) (curlet))
 		  (set! display-debug-info local-debug-info)
@@ -1154,67 +1157,123 @@
 		      ((= i 256))
 		    (set! (keymap i) normal-char))
 
-		  (set! (keymap (char->integer #\escape))
-			(lambda (c)
-			  ;; these are the Meta key handlers
-			  (let ((k (notcurses_getc nc (c-pointer 0) (c-pointer 0) ni)))
-
-			    (case (integer->char k)
-			      ((#\C #\c)
-			       (do ((len (- (eols row) col))
-				    (cur-line (ncplane_contents ncp row col 1 (- (eols row) col)))
-				    (i 0 (+ i 1)))
-				   ((or (= i len)
-					(char-alphabetic? (cur-line i)))
-				    (when (< i len)
-				      (set! (cur-line i) (char-upcase (cur-line i)))
-				      (nc-display row col cur-line)
-				      (notcurses_refresh nc)
-				      (do ((k (+ i 1) (+ k 1)))
-					  ((or (>= k len)
-					       (not (or (char-alphabetic? (cur-line k))
-							(char-numeric? (cur-line k)))))
-					   (set! col (min (eols row) (+ col k)))))))))
-
-			      ((#\L #\l)
-			       (do ((len (- (eols row) col))
-				    (cur-line (ncplane_contents ncp row col 1 (- (eols row) col)))
-				    (i 0 (+ i 1)))
-				   ((or (= i len)
-					(char-alphabetic? (cur-line i)))
-				    (when (< i len)
-				      (do ((k i (+ k 1)))
-					  ((or (= k len)
-					       (not (char-alphabetic? (cur-line k))))
-					   (nc-display row col cur-line)
-					   (notcurses_refresh nc)
-					   (set! col (+ col k)))
-					(set! (cur-line k) (char-downcase (cur-line k))))))))
-
-			      ((#\U #\u)
-			       (do ((len (- (eols row) col))
-				    (cur-line (ncplane_contents ncp row col 1 (- (eols row) col)))
-				    (i 0 (+ i 1)))
-				   ((or (= i len)
-					(char-alphabetic? (cur-line i)))
-				    (when (< i len)
-				      (do ((k i (+ k 1)))
-					  ((or (= k len)
-					       (not (char-alphabetic? (cur-line k))))
-					   (nc-display row col cur-line)
-					   (notcurses_refresh nc)
-					   (set! col (+ col k)))
-					(set! (cur-line k) (char-upcase (cur-line k))))))))
-
-			      ((#\<)
-			       (set-row 0)
-			       (set-col (bols 0)))
-
-			      ((#\>)
-			       (set-row ncp-max-row)
-			       (set-col (bols ncp-max-row)))
-
-			      )))) ; end Meta keys
+                  (define (prepend-to-selection new-text)
+                    (unless (zero? (length new-text))
+                      (set! selection (if previously-selected (append new-text selection)
+                                        new-text))
+                      (set! just-selected #t)))
+                  (define (append-to-selection new-text)
+                    (unless (zero? (length new-text))
+                      (set! selection (if previously-selected (append selection new-text)
+                                        new-text))
+                      (set! just-selected #t)))
+                  (define (char-separator? c)
+                    (char-position c " ()`',\"#"))
+                  (define (word-back-x)
+                    (let loop ((col (max (bols row) (- col 1))))
+                      (if (= col (bols row))
+                        col
+                        (if (char-separator? (ncplane_contents ncp row col 1 1))
+                          (loop (- col 1))
+                          (let loop ((col col))
+                            (if (= col (bols row))
+                              col
+                              (if (char-separator? (ncplane_contents ncp row (- col 1) 1 1))
+                                col
+                                (loop (- col 1)))))))))
+                  (define (word-forward-x)
+                    (let loop ((col (min (eols row) (+ col 1))))
+                      (if (= col (eols row))
+                        col
+                        (if (char-separator? (ncplane_contents ncp row col 1 1))
+                          (loop (+ col 1))
+                          (let loop ((col col))
+                            (if (= col (eols row))
+                              col
+                              (if (char-separator? (ncplane_contents ncp row col 1 1))
+                                col
+                                (loop (+ col 1)))))))))
+
+                  (set! (keymap (+ meta-key (char->integer #\B)))
+                    (set! (keymap (+ meta-key (char->integer #\b)))
+                      (lambda (c)
+                        (set! col (word-back-x)))))
+
+                  (set! (keymap (+ meta-key (char->integer #\C)))
+                    (set! (keymap (+ meta-key (char->integer #\c)))
+                      (lambda (c)
+                        (do ((len (- (eols row) col))
+                             (cur-line (ncplane_contents ncp row col 1 (- (eols row) col)))
+                             (i 0 (+ i 1)))
+                          ((or (= i len)
+                               (char-alphabetic? (cur-line i)))
+                           (when (< i len)
+                             (set! (cur-line i) (char-upcase (cur-line i)))
+                             (nc-display row col cur-line)
+                             (notcurses_refresh nc)
+                             (do ((k (+ i 1) (+ k 1)))
+                               ((or (>= k len)
+                                    (not (or (char-alphabetic? (cur-line k))
+                                             (char-numeric? (cur-line k)))))
+                                (set! col (min (eols row) (+ col k)))))))))))
+
+                  (set! (keymap (+ meta-key (char->integer #\D)))
+                    (set! (keymap (+ meta-key (char->integer #\d)))
+                      (lambda (c)
+                        (let ((newcol (word-forward-x)))
+                          (append-to-selection (ncplane_contents ncp row col 1 (- newcol col)))
+                          (nc-display row col (ncplane_contents ncp row newcol 1 (- (eols row) newcol)))
+                          (nc-display row (- (eols row) (- newcol col)) (make-string (- newcol col) #\space))
+                          (set! (eols row) (- (eols row) (- newcol col)))))))
+
+                  (set! (keymap (+ meta-key (char->integer #\F)))
+                    (set! (keymap (+ meta-key (char->integer #\f)))
+                      (lambda (c)
+                        (set! col (word-forward-x)))))
+
+                  (set! (keymap (+ meta-key (char->integer #\L)))
+                    (set! (keymap (+ meta-key (char->integer #\l)))
+                      (lambda (c)
+                        (do ((len (- (eols row) col))
+                             (cur-line (ncplane_contents ncp row col 1 (- (eols row) col)))
+                             (i 0 (+ i 1)))
+                          ((or (= i len)
+                               (char-alphabetic? (cur-line i)))
+                           (when (< i len)
+                             (do ((k i (+ k 1)))
+                               ((or (= k len)
+                                    (not (char-alphabetic? (cur-line k))))
+                                (nc-display row col cur-line)
+                                (notcurses_refresh nc)
+                                (set! col (+ col k)))
+                               (set! (cur-line k) (char-downcase (cur-line k))))))))))
+
+                  (set! (keymap (+ meta-key (char->integer #\U)))
+                    (set! (keymap (+ meta-key (char->integer #\u)))
+                      (lambda (c)
+                        (do ((len (- (eols row) col))
+                             (cur-line (ncplane_contents ncp row col 1 (- (eols row) col)))
+                             (i 0 (+ i 1)))
+                          ((or (= i len)
+                               (char-alphabetic? (cur-line i)))
+                           (when (< i len)
+                             (do ((k i (+ k 1)))
+                               ((or (= k len)
+                                    (not (char-alphabetic? (cur-line k))))
+                                (nc-display row col cur-line)
+                                (notcurses_refresh nc)
+                                (set! col (+ col k)))
+                               (set! (cur-line k) (char-upcase (cur-line k))))))))))
+
+                  (set! (keymap (+ meta-key (char->integer #\<)))
+                    (lambda (c)
+                      (set-row 0)
+                      (set-col (bols 0))))
+
+                  (set! (keymap (+ meta-key (char->integer #\>)))
+                    (lambda (c)
+                      (set-row ncp-max-row)
+                      (set-col (bols ncp-max-row))))
 
 		  (set! (keymap (char->integer #\tab)) tab)
 
@@ -1265,11 +1324,11 @@
 			  (ncplane_move_yx ncp ncp-row ncp-col)
 			  (reprompt row)))
 
-		  (set! (keymap (+ control-key (char->integer #\K)))
-			(lambda (c)
-			  (set! selection (ncplane_contents ncp row col 1 (- (eols row) col)))
-			  (nc-display row col (make-string (- (eols row) col) #\space))
-			  (set! (eols row) col)))
+                  (set! (keymap (+ control-key (char->integer #\K)))
+                    (lambda (c)
+                      (append-to-selection (ncplane_contents ncp row col 1 (- (eols row) col)))
+                      (nc-display row col (make-string (- (eols row) col) #\space))
+                      (set! (eols row) col)))
 
 		  (set! (keymap (+ control-key (char->integer #\L))) ; not the same as emacs's C-l (moves current row to top)
 			(lambda (c)
@@ -1338,6 +1397,23 @@
 			      (if (< cur (eols row))
 				  (set-col (+ cur 1)))))))
 
+                  (set! (keymap (+ control-key (char->integer #\U)))
+                    (lambda (c)
+                      (prepend-to-selection (ncplane_contents ncp row (bols row) 1 (- col (bols row))))
+                      (nc-display row (bols row) (ncplane_contents ncp row col 1 (- (eols row) col)))
+                      (nc-display row (- (eols row) (- col (bols row))) (make-string (- col (bols row)) #\space))
+                      (set! (eols row) (- (eols row) (- col (bols row))))
+                      (set! col (bols row))))
+
+                  (set! (keymap (+ control-key (char->integer #\W)))
+                    (lambda (c)
+                      (let ((newcol (word-back-x)))
+                        (prepend-to-selection (ncplane_contents ncp row newcol 1 (- col newcol)))
+                        (nc-display row newcol (ncplane_contents ncp row col 1 (- (eols row) col)))
+                        (nc-display row (- (eols row) (- col newcol)) (make-string (- col newcol) #\space))
+                        (set! (eols row) (- (eols row) (- col newcol)))
+                        (set! col newcol))))
+
 		  (set! (keymap (+ control-key (char->integer #\Y)))
 			(lambda (c)
 			  (when (string? selection)
@@ -1350,7 +1426,7 @@
 				       (> (length trailing) 0))
 				  (nc-display row (+ col (length selection)) trailing)))
 			    (set! (eols row) (+ (eols row) (length selection)))
-			    (set-col (eols row)))))
+			    (set-col (+ col (length selection))))))
 
 		  (set! (keymap NCKEY_LEFT)       ; arrow keys
 			(lambda (c)
@@ -1472,8 +1548,15 @@
 			  (when recursor
 			    (recover-previous-layout))
 
+                          (set! previously-selected just-selected)
+                          (set! just-selected #f)
+
 			  (let* ((c (notcurses_getc nc (c-pointer 0) (c-pointer 0) ni))
-				 (func (hash-table-ref keymap (if (ncinput_ctrl ni) (+ c control-key) c))))
+                                 (c (if (= c (char->integer #\escape))
+                                      (logior meta-key (notcurses_getc nc (c-pointer 0) (c-pointer 0) ni))
+                                      c))
+				 (func (hash-table-ref keymap (logior c (if (ncinput_ctrl ni) control-key 0)
+                                                                        (if (ncinput_alt ni) meta-key 0)))))
 
 			    (if (procedure? func)
 				(catch #t

From bil at ccrma.Stanford.EDU  Sun Jul 18 02:53:01 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Sun, 18 Jul 2021 02:53:01 -0700
Subject: [CM] Navigation in nrepl
In-Reply-To: <ea8c383b-a2d8-63a0-82c7-5e10d61cc368@elronnd.net>
References: <ea8c383b-a2d8-63a0-82c7-5e10d61cc368@elronnd.net>
Message-ID: <f11943dbf2c3a8269a0408f814549754@ccrma.stanford.edu>

Wow!  Thanks! I'll merge those changes into my version
later today.



From elronnd at elronnd.net  Sun Jul 18 18:36:02 2021
From: elronnd at elronnd.net (Elijah Stone)
Date: Sun, 18 Jul 2021 18:36:02 -0700 (PDT)
Subject: [CM] s7: segfault on infinitely recursive macro
Message-ID: <fa6952bf-9826-4bdc-1242-df5b2b92a540@elronnd.net>

(define-macro (f) (f))
(f) ;segfault
(letrec ((f (macro () (f)))) (f)) ;ditto

Same thing happens for define-expansion, but not for a regular function.


From bil at ccrma.Stanford.EDU  Mon Jul 19 02:56:31 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Mon, 19 Jul 2021 02:56:31 -0700
Subject: [CM] s7: segfault on infinitely recursive macro
In-Reply-To: <fa6952bf-9826-4bdc-1242-df5b2b92a540@elronnd.net>
References: <fa6952bf-9826-4bdc-1242-df5b2b92a540@elronnd.net>
Message-ID: <470d5fd572ed84c4b448fac4249f39f9@ccrma.stanford.edu>

Thanks!  s7.c line 77444 (and 77457 for macro*) needs

check_stack_size(sc);

before the push_stack. I think this also covers expansions and bacros.



From iainduncanlists at gmail.com  Mon Jul 19 15:13:49 2021
From: iainduncanlists at gmail.com (Iain Duncan)
Date: Mon, 19 Jul 2021 15:13:49 -0700
Subject: [CM] s4pd (s7 for pd) with [text] perhaps for live-coding
In-Reply-To: <CAAn-EcyYkTQnJ7gSHWXVZZ863fbD53Tzu4_ipZg_RPJwiuqQ3A@mail.gmail.com>
References: <CAAn-EcyYkTQnJ7gSHWXVZZ863fbD53Tzu4_ipZg_RPJwiuqQ3A@mail.gmail.com>
Message-ID: <CAN9NcLynXGvVTLoNw0KxCu8djGu5Fg_1OxJujFe3jrxmWZk7YQ@mail.gmail.com>

Thanks Forrest, I will try this out! I just wrapped up a bunch of paper
writing and have some time to dedicate to s4pd again.

Right now each object is isolated on its own, because one can always use
send and receives to simulate sharing, and use shared data structures as
noted.

Also, I should probably request you send s4pd or s4m specific things to the
scheme for max google group just so as not to clutter up this list. I'll go
rename the group to indicate it's for Pd as well now!
iain

On Sat, Jul 17, 2021 at 7:05 AM Forrest Curo <treegestalt at gmail.com> wrote:

> [text define cod]
> ----------
> [line 0(
> | [step(
> |/
> [text sequence cod]
> |
> [send cud]
> ---------
> [receive cud]
> |
> [list trim]             (This is needed with output from 'text')
> |
> [fudiform -u]
> |
> [list tosymbol]
> |
> [s4pd]
> |
> [print]
> ==========
> Clicking on the [text define] box opens it for input, without having to go
> into edit-mode. If you want what you type into it to remain stable, lines
> should end with ';'
>
> To make what you've just typed in to be visible to [s4pd] you need to save
> it. Closing the box is one way, but cumbersome, and leaves it
> inconveniently closed. So: ctrl-s does the job.
> =========
> Questions, by the way. Each [s4pd] runs its own separate line of
> execution... Is there a built-in way for one [s4pd] to receive messages
> from or share a variable with another? (I suppose they could both reference
> the same pd [array]. Pd would be executing code from each box in sequence,
> according to its signal flow?)
> _______________________________________________
> Cmdist mailing list
> Cmdist at ccrma.stanford.edu
> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210719/2efc6243/attachment.html>

From dev at mobileink.com  Mon Jul 19 18:37:08 2021
From: dev at mobileink.com (Gregg Reynolds)
Date: Mon, 19 Jul 2021 20:37:08 -0500
Subject: [CM] scheme unit testing framework?
Message-ID: <CAO40MikUkg8HeGogMJ9SE+dUZj6d_NxV9D6vGzNJ8dBZL3y4TA@mail.gmail.com>

Any recommendations for a unit testing framework that works with s7?  I'm
rapidly getting to the point where testing at the REPL is inadequate.

Thanks,

Gregg
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210719/ad3d7e74/attachment.html>

From iainduncanlists at gmail.com  Mon Jul 19 19:01:45 2021
From: iainduncanlists at gmail.com (Iain Duncan)
Date: Mon, 19 Jul 2021 19:01:45 -0700
Subject: [CM] scheme unit testing framework?
In-Reply-To: <CAO40MikUkg8HeGogMJ9SE+dUZj6d_NxV9D6vGzNJ8dBZL3y4TA@mail.gmail.com>
References: <CAO40MikUkg8HeGogMJ9SE+dUZj6d_NxV9D6vGzNJ8dBZL3y4TA@mail.gmail.com>
Message-ID: <CAN9NcLxxnH8X9QwBrX4ER5P0vsjBqo=C3Oowvfhdhkik9-CsBQ@mail.gmail.com>

Hi Gregg, I know there exists one for Racket (RackUnit), which might not be
hard to adapt.

However, it is honestly probably just as easy to roll your own. S7's
support for environments makes it very easy to set up the context for a
call and assert. Check out with-let and let-ref in the s7.html page, and
the stuff on environments as an optional 3rd arg to eval.

hth
iain

On Mon, Jul 19, 2021 at 6:37 PM Gregg Reynolds <dev at mobileink.com> wrote:

> Any recommendations for a unit testing framework that works with s7?  I'm
> rapidly getting to the point where testing at the REPL is inadequate.
>
> Thanks,
>
> Gregg
> _______________________________________________
> Cmdist mailing list
> Cmdist at ccrma.stanford.edu
> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210719/66ab6cb3/attachment.html>

From chris.actondev at gmail.com  Tue Jul 20 00:16:39 2021
From: chris.actondev at gmail.com (Christos Vagias)
Date: Tue, 20 Jul 2021 09:16:39 +0200
Subject: [CM] scheme unit testing framework?
In-Reply-To: <CAN9NcLxxnH8X9QwBrX4ER5P0vsjBqo=C3Oowvfhdhkik9-CsBQ@mail.gmail.com>
References: <CAO40MikUkg8HeGogMJ9SE+dUZj6d_NxV9D6vGzNJ8dBZL3y4TA@mail.gmail.com>
	<CAN9NcLxxnH8X9QwBrX4ER5P0vsjBqo=C3Oowvfhdhkik9-CsBQ@mail.gmail.com>
Message-ID: <CAG02pQhs==RDvdm7wg8d59_D29e28LrcVj=7g4N1upDQqDmxuA@mail.gmail.com>

Hi Gregg,

Check stuff.scm in s7's repo, there's an example assert or test macro if I
recall correctly.
It's fairly easy to expand with this. I have some setup in my environment,
could send some snippets later tonight (CET time here)

On Tue, Jul 20, 2021, 4:02 AM Iain Duncan <iainduncanlists at gmail.com> wrote:

> Hi Gregg, I know there exists one for Racket (RackUnit), which might not
> be hard to adapt.
>
> However, it is honestly probably just as easy to roll your own. S7's
> support for environments makes it very easy to set up the context for a
> call and assert. Check out with-let and let-ref in the s7.html page, and
> the stuff on environments as an optional 3rd arg to eval.
>
> hth
> iain
>
> On Mon, Jul 19, 2021 at 6:37 PM Gregg Reynolds <dev at mobileink.com> wrote:
>
>> Any recommendations for a unit testing framework that works with s7?  I'm
>> rapidly getting to the point where testing at the REPL is inadequate.
>>
>> Thanks,
>>
>> Gregg
>> _______________________________________________
>> Cmdist mailing list
>> Cmdist at ccrma.stanford.edu
>> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>>
> _______________________________________________
> Cmdist mailing list
> Cmdist at ccrma.stanford.edu
> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210720/32dfb3f1/attachment.html>

From bchristensen-lists at outlook.com  Tue Jul 20 00:20:21 2021
From: bchristensen-lists at outlook.com (Brad Christensen)
Date: Tue, 20 Jul 2021 07:20:21 +0000
Subject: [CM] Bug in cload init function generation
Message-ID: <SJ0PR02MB7213F0D1D3EA1EFA570232AAB8E29@SJ0PR02MB7213.namprd02.prod.outlook.com>

Greetings,

I have begun to explore `c-define` and friends and I think I've found a bug . I declared a `c-define` with a single 'C entity' that is a list of constants:
```
(c-define
 '((uint32_t (SOME_CONSTANT
                   ANOTHER_CONSTANT
                   ETC_CONSTANT)))
 "" "required/header.h" "" "" "libName_s7")
```
In the generated C file, it appears unneeded syntax is written where it looks like optimization signatures would normally be declared (lines 5-6):
```
01| . . .
02| void libName_s7_init(s7_scheme *sc)
03| {
04|   s7_pointer cur_env;
05|   s7_pointer
06|   }
07| 
08|   cur_env = s7_curlet(sc);
09| . . .
```
Cheers, Brad


From bil at ccrma.Stanford.EDU  Tue Jul 20 05:48:33 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Tue, 20 Jul 2021 05:48:33 -0700
Subject: [CM] Bug in cload init function generation
In-Reply-To: <SJ0PR02MB7213F0D1D3EA1EFA570232AAB8E29@SJ0PR02MB7213.namprd02.prod.outlook.com>
References: <SJ0PR02MB7213F0D1D3EA1EFA570232AAB8E29@SJ0PR02MB7213.namprd02.prod.outlook.com>
Message-ID: <2e4bcaf7e46f23e6af93e991c11de0e6@ccrma.stanford.edu>

Thanks for the bug report.  cload is assuming there is at least
one function, so to fix that I think you can just change
line 501:

501c501,502
< 	(format p "  s7_pointer ")
---
> 	(when (> (hash-table-entries signatures) 0)
> 	  (format p "  s7_pointer "))




From dev at mobileink.com  Tue Jul 20 18:21:16 2021
From: dev at mobileink.com (Gregg Reynolds)
Date: Tue, 20 Jul 2021 20:21:16 -0500
Subject: [CM] s7_string v. s7_object_to_c_string
Message-ID: <CAO40Min-A21eyJM31jVTJa-wKy8WXC2+R0_cqi8akydTA4++7A@mail.gmail.com>

If I s7_make_string(sc, filename), then convert the s7_pointer back to a C
string, the two functions s7_string and s7_object_to_c_string should
produce identical output, no? Namely a string identical to the original
source. That's what I would expect, anyway.

I just found something fishy about s7_object_to_c_string.  I'm passing a
string to use with fopen. The fopen fails (as does access()) if I use it,
but succeeds if I use s7_string to do the conversion.

Furthermore, if I print the char* string after conversion, it looks ok.

Is this a bug?

Thanks,

Gregg
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210720/6a8d63d6/attachment.html>

From elronnd at elronnd.net  Tue Jul 20 18:16:07 2021
From: elronnd at elronnd.net (Elijah Stone)
Date: Tue, 20 Jul 2021 18:16:07 -0700 (PDT)
Subject: [CM] s7 GC bug
Message-ID: <e498ad4a-4adb-4a66-ea1f-28191ef4fd46@elronnd.net>

Attempting to run the attached file gives an error 'attempt to apply a 
free cell', which seems (?) like a gc bug.  (Although, it still happens 
when I run (gc #f), which seems weird.)

Setting (*s7* 'safety) to 1 results in a (clearly bogus) error about an 
unbound variable instead.

I'm fairly confident that the problematic form is in the last 150 lines 
(of a nearly 4000-line file!), but--well, reducing is never easy.

  -E
-------------- next part --------------
(define loop (let ()
(define transform-tagbody
  (let ()
    ;; from guile-user I think
    ;; (block LABEL FORMS...)
    ;;
    ;; Execute FORMS.  Within FORMS, a lexical binding named LABEL is
    ;; visible that contains an escape function for the block.  Calling
    ;; the function in LABEL with a single argument will immediatly stop
    ;; the execution of FORMS and return the argument as the value of the
    ;; block.  If the function in LABEL is not invoked, the value of the
    ;; block is the value of the last form in FORMS.

    (define-macro (block label . forms)
                  `(let ((body (lambda (,label) , at forms))
                         (tag (gensym "return-")))
                     (catch tag
                            (lambda () (body (lambda (val) (throw tag val))))
                            (lambda (tag val) val))))

    ;; (with-return FORMS...)
    ;;
    ;; Equivalent to (block return FORMS...)

    (define-macro (with-return . forms)
                  `(,block return , at forms))

    ;; (tagbody TAGS-AND-FORMS...)
    ;;
    ;; TAGS-AND-FORMS is a list of either tags or forms.  A TAG is a
    ;; symbol while a FORM is everything else.  Normally, the FORMS are
    ;; executed sequentially.  However, control can be transferred to the
    ;; forms following a TAG by invoking the tag as a function.  That is,
    ;; within the FORMS, there is a lexical binding for each TAG with the
    ;; symbol that is the tag as its name.  The bindings carry functions
    ;; that will execute the FORMS following the respective TAG.
    ;;
    ;; The value of a tagbody is always `#f'.

    (define (transform-tagbody forms)
      (let ((start-tag (gensym "start-"))
            (block-tag (gensym "block-")))
        (let loop ((cur-tag start-tag)
                   (cur-code ())
                   (tags-and-code ())
                   (forms forms))
          (cond
            ((null? forms)
             `(,block ,block-tag
                     (letrec ,(reverse! (cons (list cur-tag `(lambda () ,@(reverse! (cons `(,block-tag #f) cur-code)))) tags-and-code))
                       (,start-tag))))
            ((symbol? (car forms))
             (loop (car forms)
                   '()
                   (cons (list cur-tag `(lambda () ,@(reverse! (cons `(,(car forms)) cur-code)))) tags-and-code)
                   (cdr forms)))
            (else
              (loop cur-tag
                    (cons (car forms) cur-code)
                    tags-and-code
                    (cdr forms)))))))
    transform-tagbody))
;(define-macro (transform-tagbody . forms) (transform-tagbody forms))
(define-macro (push v s)
  (unless (symbol? s) (error))
  `(begin (set! ,s (cons ,v ,s)) ,s))

(define (list* . p)
  (if (null? (cdr p))
    (car p)
    (cons (car p) (apply list* (cdr p)))))

; a la j: x f&g y ?? (f x) g (f y)
; hence, ((& f g) x y z...) ?? (f (g x) (g y) (g z)...)
(define (compose f g) (lambda args (apply f (map g args))))
; and here: x (f g) y ?? x f g y
; ((hook f g) x y) ?? (f x (g y))
(define (hook f g) (lambda (x y) (f x (g y))))
; in particular, cl (higher-order-fn :pred f :key g)
; can be expressed here using simply (higher-order fn :pred (hook f g))
(define (bind f . rest) (lambda args (apply f (append rest args))))
(define (rbind f . rest) (lambda args (apply f (append args rest))))

(define (filter f xs)
  (cond
    ((null? xs) '())
    ((f (car xs)) (cons (car xs) (filter f (cdr xs))))
    (#t (filter f (cdr xs)))))
(define (any f l) (not (null? (filter f l))))

(define (constantly val)
  (lambda - val))

(define (identity x) x)

(define (remove-duplicates l pred)
  (let ((ret '()))
    (let loop ((l l))
      (unless (null? l)
        (unless (any (lambda (x) (pred x (car l))) ret)
          (push (car l) ret))
        (loop (cdr l))))
    (reverse ret)))

(define (remove-duplicates-from-end l pred)
  (let ((ret '()))
    (let loop ((l l))
      (unless (null? l)
        (loop (cdr l))
        (unless (any (lambda (x) (pred x (car l))) ret)
          (push (car l) ret))))
    ret))

(define (every f l)
  (if (null? l)
    #t
    (and (f (car l))
         (every f (cdr l)))))

(define (position-if pred l)
  (let loop ((l l)
             (i 0))
    (cond
      ((null? l) #f)
      ((pred (car l)) i)
      (#t (loop (cdr l) (+ 1 i))))))

(define (position-if-from-end pred l)
  (let loop ((l l)
             (i 0))
    (cond ((null? l) #f)
          ((pred (car l)) (or (loop (cdr l) (+ 1 i)) i))
          (#t (loop (cdr l) (+ 1 i))))))

(define (for-each-on f xs)
  (if (null? xs)
    '()
    (begin
      (f xs)
      (for-each-on f (cdr xs)))))

(define (count x xs pred)
  (let loop ((xs xs)
             (acc 0))
    (if (null? xs) acc
      (loop (cdr xs) (+ acc (if (pred x (car xs)) 1 0))))))

(define (intersection x y pred)
  (filter (rbind member y pred) x))

; to make up for multiple-value-bind
(define-macro (pidgin-destructuring-bind spec var . body)
  (let ((v (gensym)))
    (letrec ((expand (lambda (spec)
                       (format #t "A~%")
                       (if (null? spec)
                         (begin (format #t "B~%") `((unless (null? ,v) (error "too many values specified for destructuring"))))
                         (begin (format #t "B~%") (list* `(set! ,(car spec) (car ,v))
                                `(set! ,v (cdr ,v))
                                (expand (cdr spec))))))))
      `(let ((,v ,var)
             ,@(map (lambda (s) `(,s #f)) spec))
         ,@(expand spec)
         , at body))))

; simple stub generics implementation (single dispatch only)
; (defgeneric m (x y z) body*)  will define a function 'm' that expects 'x' to
; be a let containing a bound lambda 'm'; y and z will be passed to that
; lambda.  If 'm' is not bound, body will be evaluated instead.  If body is
; nil, an error will be signaled

(define-macro (defgeneric name pspec . body)
  `(define (,name , at pspec)
     (if (eq? ,name (,(car pspec) ',name))
       ,(if (null? body) `(error "No method ~a bound in class ~a" ',name (,(car pspec) 'class-name)) `(begin , at body))
       ((,(car pspec) ',name) , at pspec))))

(define *classes* (make-hash-table 8 eq?))

(define (type-specifier? x) (or (symbol? x) (eq? x #f)))

(define-macro (defclass name super slots . methods)
  (when (*classes* name) (error "Class already defined: ~a" name))
  (let* ((super (map (lambda (s) (let ((r (*classes* s))) (unless r (error "No superclass ~a" s)) r)) super))
         (auxiliary-slots   (apply append (map (lambda (c) (c 'all-slots)) super)))
         (auxiliary-methods (apply append (map (lambda (c) (c 'all-methods)) super)))
         (methods (map (lambda (m) `(,(car m) (lambda* ,(cadr m) ,@(cddr m)))) methods))
         (slots (map (lambda (s) (if (pair? s) s `(,s (error ,(format #f "No initializer supplied for slot ~a" s))))) slots))
         (accessor-methods '())
         (all-slots (remove-duplicates-from-end `(, at auxiliary-slots , at slots) (compose eq? car)))
         (all-methods (remove-duplicates-from-end `(, at auxiliary-methods , at accessor-methods , at methods) (compose eq? car)))
         (classes (cons name (remove-duplicates (apply append (map (lambda (x) (x 'classes)) super)) eq?))))
    `(set! (*classes* ',name)
           (inlet 'all-slots ',all-slots
                  'all-methods ',all-methods
                  'class-name ',name
                  'classes ',classes
                  'make (lambda* ,all-slots
                          (let ((class-name ',name)
                                , at all-methods)
                            (curlet)))))))

(define (make-instance what . p)
  (apply ((*classes* what) 'make) p))

(define (type? var type) (member type ((*classes* (var 'class-name)) 'classes)))
;;; The purpose of this generic function is to generate a list of all
;;; bound variables in a clause.  The same variable occurs as many
;;; times in the list as the number of times it is bound in the
;;; clause.
(defgeneric bound-variables (clause))

;;; The purpose of this generic function is to generate a list of all
;;; the accumulation variables in a clause.  Each element of the list
;;; is itself a list of three elements.  The first element is the name
;;; of a variable used in an INTO clause, or NIL if the clause has no
;;; INTO.  The second element determines the kind of accumulation, and
;;; can be one of the symbols LIST, COUNT/SUM, or MAX/MIN.  The third
;;; element is a type specifier which can be T.
; NB. the scheme port uses #f instead of nil.
(defgeneric accumulation-variables (clause))

;;; The purpose of this generic function is to extract a list of
;;; declaration specifiers from the clause.  Notice that it is a list
;;; of declaration specifiers, not a list of declarations.  In other
;;; words, the symbol DECLARE is omitted.
(defgeneric declarations (clause)
  '())

(defgeneric initial-bindings (clause)
  '())

(defgeneric final-bindings (clause)
  '())

(defgeneric bindings (clause)
  (append (initial-bindings clause) (final-bindings clause)))

;;; This generic function returns a form for CLAUSE that should go in
;;; the LOOP prologue.  The INITIALLY clause is an obvious candidate
;;; for such code.  But the stepping clauses also have code that goes
;;; in the prologue, namely an initial termination test to determine
;;; whether any iterations at all should be executed.  END-TAG is the
;;; tag to GO to when the initial termination test says that no
;;; iterations should be executed.
(defgeneric prologue-form (clause end-tag)
  '())

;;; This generic function returns a form for CLAUSE that should go
;;; between the body code and the stepping forms in the body of the
;;; expanded code.  Some of the FOR-AS clauses and also the REPEAT
;;; clause generate code here.  END-TAG is the tag to GO to when
;;; iteration should terminate.
(defgeneric termination-form (clause end-tag)
  '())

;;; This generic function returns a form for CLAUSE that should go in
;;; the main the body code, before the termination test and the
;;; stepping forms, in the body of the expanded code.  The DO clause
;;; and the accumulation clauses are obvious candidates for such code.
;;;
;;; FIXME: Currently, END-TAG is used only in the WHILE clause as a
;;; termination test.  Investigate whether the WHILE clause should use
;;; TERMINATION-TEST instead, so that we can eliminate this parameter.
(defgeneric body-form (clause end-tag)
  '())

;;; This generic function returns a form for CLAUSE that should go
;;; after the main body code and the termination tests in the body of
;;; the expanded code.  The FOR-AS clauses and also the REPEAT clause
;;; generate code here.
(defgeneric step-form (clause)
  '())

;;; This generic function returns a form for CLAUSE that should go in
;;; the LOOP epilogue.  Of the clause types defined by the Common Lisp
;;; standard, only the method specialized to the FINALLY clause
;;; returns a value other than NIL.
(defgeneric epilogue-form (clause)
  '())

;;; Once the LOOP prologue, the LOOP body, and the LOOP epilogue have
;;; all been constructed, a bunch of successive WRAPPERS are applied
;;; so as to obtain the final expansion.  Each clause type defines how
;;; it needs to be wrapped.  Some clauses only require the
;;; establishment of variable bindings in the wrapper.  Other clauses
;;; might need to be wrapped in some iterator form.  The generic
;;; function WRAP-CLAUSE defines how each clause type is wrapped.
;;; The default method is applicable only if the clause type does not
;;; admit any subclauses.  For this type of clause, the default
;;; implemented here is to wrap the clause in all the bindings, i.e.,
;;; both the initial and the final bindings of both exist.
(defgeneric wrap-clause (clause inner-form)
  `(let* ,(bindings clause)
     ,inner-form))

;;; If a clause can have subclauses, then each subclause may need to
;;; be wrapped separately.  The generic function WRAP-SUBCLAUSE
;;; determines how this is done.
;;; By default, the wrapper for each subclause contains only the final
;;; bindings, leaving the initial bindings to a single binding form of
;;; the entire clause.
(defgeneric wrap-subclause (subclause inner-form)
  `(let ,(final-bindings subclause)
     ,inner-form))

;;; This variable is bound by the code generator for
;;; CONDITIONAL-CLAUSE before calling the code generators for the
;;; clauses in its THEN and ELSE branches.
(define *it-var* #f)

(define *accumulation-variable* #f)

(define *list-tail-accumulation-variable* #f)

(define *tail-variables* #f)

(define *loop-name* #f)

(define *loop-return-sym* #f)


(define *indent-level* 0)
(define *parse-trace?* #f)
;;; compare symbols and keywords indiscriminantly
(define (symbol-equal symbol1 symbol2)
  (let ((f (lambda (x) (if (keyword? x) (keyword->symbol x) x))))
    (let ((symbol1 (f symbol1))
          (symbol2 (f symbol2)))
      (and (symbol? symbol1)
           (symbol? symbol2)
           (eq? symbol1 symbol2)))))

;;; This function generates code for destructuring a value according
;;; to a tree of variables.  D-VAR-SPEC is a tree of variable names
;;; (symbols).  FORM is a form that, at runtime, computes the value to
;;; be assigned to the root of D-VAR-SPEC.  This function returns a
;;; list of bindings to be used in a LET* form.  These bindings
;;; destructure the root value until the leaves of the tree are
;;; reached, generating intermediate temporary variables as necessary.
;;; The destructuring code calls the function LIST-CAR and LIST-CDR so
;;; that an error is signaled whenever the corresponding place in the
;;; value tree is not a CONS cell.
(define (destructure-variables d-var-spec form)
  (let ((bindings '()))
    (letrec ((traverse (lambda (d-var-spec form)
               (cond ((null? d-var-spec))
                     ((symbol? d-var-spec)
                      (push `(,d-var-spec ,form) bindings))
                     ((not (pair? d-var-spec))
                      (error 'expected-var-spec-but-found
                             :found d-var-spec))
                     (#t
                      (let ((temp (gensym)))
                        (push `(,temp ,form) bindings)
                        (traverse (car d-var-spec) `(,list-car ,temp))
                        (traverse (cdr d-var-spec) `(,list-cdr ,temp))))))))
      (traverse d-var-spec form)
      (reverse bindings))))

;;; Given a D-VAR-SPEC, compute a D-VAR-SPEC with the same structure
;;; as the one given as argument, except that the non-NIL leaves
;;; (i.e., the variables names) have been replaced by fresh symbols.
;;; Return two values: the new D-VAR-SPEC and a dictionary in the form
;;; of an association list that gives the correspondence between the
;;; original and the new variables.
(define (fresh-variables d-var-spec)
  (let* ((dictionary '()))
    (letrec ((traverse (lambda (d-var-spec)
               (cond ((null? d-var-spec) '())
                     ((symbol? d-var-spec)
                      (let ((temp (gensym)))
                        (push (cons d-var-spec temp) dictionary)
                        temp))
                     (#t
                      (cons (traverse (car d-var-spec))
                            (traverse (cdr d-var-spec))))))))
      (list (traverse d-var-spec)
            (reverse dictionary)))))

(define (generate-assignments d-var-spec form)
  (pidgin-destructuring-bind (temp-d-var-spec dictionary)
                             (fresh-variables d-var-spec)
    (if (null? dictionary)
      ()
      `(let* ,(destructure-variables temp-d-var-spec form)
         ,@(map (lambda (t) `(set! ,(car t) ,(cdr t))) dictionary)))))

;;; Extract variables
(define (extract-variables d-var-spec d-type-spec)
  (let ((result '()))
    (letrec ((extract-aux (lambda (d-var-spec d-type-spec)
               (cond ((null? d-var-spec))
                     ((symbol? d-var-spec)
                      (push (list d-var-spec (or d-type-spec 't)) result))
                     ((type-specifier? d-type-spec)
                      (if (not (pair? d-var-spec))
                          (error 'expected-var-spec-but-found
                                 :found d-var-spec)
                          (begin (extract-aux (car d-var-spec) d-type-spec)
                                 (extract-aux (cdr d-var-spec) d-type-spec))))
                     ((not (pair? d-var-spec))
                      (error 'expected-var-spec-but-found
                             :found d-var-spec))
                     ((not (pair? d-type-spec))
                      (error 'expected-type-spec-but-found
                             :found d-type-spec))
                     (#t
                      (extract-aux (car d-var-spec) (if d-type-spec (car d-type-spec) #f))
                      (extract-aux (cdr d-var-spec) (if d-type-spec (cdr d-type-spec) #f)))))))
      (extract-aux d-var-spec d-type-spec)
      result)))
;;; A parser is a function that takes a list of tokens to parse, and
;;; that returns three values:
;;;
;;;   * A generalized Boolean indicating whether the parse succeeded.
;;;
;;;   * The result of the parse.  If the parse does not succeed, then
;;;     this value is unspecified.
;;;
;;;   * A list of the tokens that remain after the parse.  If the
;;;     parse does not succeed, then this list contains the original
;;;     list of tokens passed as an argument.

;;; Functions that take one or more parsers as arguments can take
;;; either a function or the name of a function.

(define (parse-trace-output format-control . arguments)
  (when *parse-trace?*
    (format #t (make-string (* 2 *indent-level*) #\space))
    (apply format #t format-control arguments)))

(define (trace-parser name parser tokens)
  (let-temporarily ((*indent-level* (+ 1 *indent-level*)))
    (parse-trace-output "trying ~s on ~s~%" name tokens)
    (pidgin-destructuring-bind (successp result rest)
        (parser tokens)
      (parse-trace-output "~asuccess~%" (if successp "" "no "))
      (list successp result rest))))

(define-macro (define-parser name . body)
  `(define (,name tokens) (trace-parser ',name (begin , at body) tokens)))

;;; Take a function designator (called the TRANSFORMER) and a
;;; predicate P and return a parser Q that invokes the predicate on
;;; the first token.  If P returns true then Q succeeds and returns
;;; the result of invoking TRANSFORMER on the token together with the
;;; remaining tokens (all tokens except the first one).  If P returns
;;; false, then Q fails.  If there are no tokens, then Q also fails.
(define (singleton transformer predicate)
  (lambda (tokens)
    (if (and (not (null? tokens))
             (predicate (car tokens)))
        (list #t (transformer (car tokens)) (cdr tokens))
        (list #f #f tokens))))

;;; Take a list of parsers P1, P2, ..., Pn and return a parser Q that
;;; invokes Pi in order until one of them succeeds.  If some Pi
;;; succeeds. then Q also succeeds with the same result as Pi.  If
;;; every Pi fails, then Q also fails.
(define (alternative . parsers)
  (lambda (tokens)
    (let loop ((parsers parsers))
      (if (null? parsers)
        (list #f #f tokens)
        (pidgin-destructuring-bind (success result rest)
          ((car parsers) tokens)
          (if success
            (list #t result rest)
            (loop (cdr parsers))))))))

;;; Take a function designator (called the COMBINER) and a list of
;;; parsers P1, P2, ..., Pn and return a parser Q that invokes every
;;; Pi in order.  If any Pi fails, then Q fails as well.  If every Pi
;;; succeeds, then Q also succeeds and returns the result of calling
;;; APPLY on COMBINER and the list of results of the invocation of
;;; each Pi.
(define (consecutive combiner . parsers)
  (lambda (tokens)
    (let loop ((remaining-tokens tokens)
               (remaining-parsers parsers)
               (results '()))
      (if (null? remaining-parsers)
        (list #t (apply combiner (reverse results)) remaining-tokens)
        (pidgin-destructuring-bind (success result rest)
          ((car remaining-parsers) remaining-tokens)
          (if success
            (loop rest (cdr remaining-parsers) (cons result results))
            (list #f #f tokens)))))))

;;; Take a function designator (called the COMBINER) and a parser P
;;; and return a parser Q that invokes P repeatedly until it fails,
;;; each time with the tokens remaining from the previous invocation.
;;; The result of the invocation of Q is the result of calling APPLY
;;; on COMBINER and the list of the results of each invocation of P.
;;; Q always succeeds.  If the first invocation of P fails, then Q
;;; succeeds returning the result of calling APPLY on COMBINER and the
;;; empty list of results, and the original list of tokens as usual.
(define (repeat* combiner parser)
  (lambda (tokens)
    (let loop ((remaining-tokens tokens)
               (results '()))
      (pidgin-destructuring-bind (success result rest)
          (parser remaining-tokens)
        (if success
          (loop rest (cons result results))
          (list #t (apply combiner (reverse results)) remaining-tokens))))))

;;; Take a function designator (called the COMBINER) and a parser P
;;; and return a parser Q that invokes P repeatedly until it fails,
;;; each time with the tokens remaining from the previous invocation.
;;; The result of the invocation of Q is the result of calling APPLY
;;; on COMBINER and the list of the results of each invocation of P.
;;; Q succeeds if and only if at least one invocation of P succeeds.
(define (repeat+ combiner parser)
  (lambda (tokens)
    (pidgin-destructuring-bind (success result rest)
        (parser tokens)
        (if (not success)
          (list #f #f tokens)
          (let loop ((remaining-tokens rest)
                     (results (list result)))
            (pidgin-destructuring-bind (success result rest)
                (parser remaining-tokens)
              (if success
                (loop rest (cons result results))
                (list #t (apply combiner (reverse results)) remaining-tokens))))))))

;;; Take a default value and a parser P and return a parser Q that
;;; always succeeds.  Q invokes P once.  If P succeeds, then Q
;;; succeeds with the same result as P and with the same remaining
;;; tokens.  If P fails, then Q succeeds, returning the default value
;;; and the original list of tokens.
(define (optional default parser)
  (lambda (tokens)
    (pidgin-destructuring-bind (success result rest)
        (parser tokens)
      (if success
          (list #t result rest)
          (list #t default tokens)))))

;;;  LocalWords:  parsers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Given a symbol S (no matter what package), return a singleton
;;; parser Q that recognizes symbols with the same name as S.  If Q
;;; succeeds, it returns S.

(define (keyword-parser symbol)
  (singleton (constantly symbol)
             (lambda (token) (symbol-equal symbol token))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser for anything, i.e. a parser that succeeds whenever the list
;;; of tokens is not empty.  It returns the first token as a result of
;;; the parse, and the list of tokens with the first one removed as
;;; the list of remaining tokens.

(define-parser anything-parser
  (singleton identity (constantly #t)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; A parser that recognizes one of the LOOP keywords EACH and THE.
;;; It is used to parse FOR-AS-HASH and FOR-AS-PACKAGE subclauses.

(define-parser each-the-parser
  (alternative (keyword-parser 'each)
               (keyword-parser 'the)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; A parser that recognizes one of the LOOP keywords IN and OF.
;;; It is used to parse FOR-AS-HASH and FOR-AS-PACKAGE subclauses.

(define-parser in-of-parser
  (alternative (keyword-parser 'in)
               (keyword-parser 'of)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; A parser that recognizes one of the LOOP keyword BEING.
;;; It is used to parse FOR-AS-HASH and FOR-AS-PACKAGE subclauses.

(define-parser being-parser
  (keyword-parser 'being))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser for COMPOUND-FORM+, i.e. a non-empty sequence of compound
;;; forms.

(define-parser compound+
  (repeat+ (lambda forms
             (cons 'begin forms))
           (singleton identity pair?)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; This parser succeeds whenever the list of tokens is either empty
;;; or starts with a form that is not a loop keyword that can start a
;;; clause.  When it succeeds, it returns NIL as the result and the
;;; original list of tokens.

(define *clause-keywords*
  '(initially finally
    with
    do return
    collect collecting
    append appending
    nconc nconcing
    count counting
    sum summing
    maximize maximizing
    minimize minimizing
    if when unless
    while until repeat always never thereis
    for as))

(define (non-clause-keyword tokens)
  (if (or (null tokens)
          (member (car tokens) *clause-keywords*
                  symbol-equal))
      (list #t #f tokens)
      (list #f #f tokens)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Manage a list of clause parsers.

(define *clause-parsers* '())

(define (add-clause-parser parser)
  (push parser *clause-parsers*))

;;; A parser that tries every parser in *CLAUSE-PARSERS* until one
;;; succeeds.

(define (parse-clause tokens)
  (let loop ((parsers *clause-parsers*))
    (if (null? parsers)
      (list #f #f tokens)
      (pidgin-destructuring-bind (success result rest)
        ((car parsers) tokens)
        (if success
          (list #t result rest)
          (loop (cdr parsers)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Class LOOP-BODY.
;;;
;;; An instance of this class is the result of parsing the clauses.

;(defclass loop-body ()
;  ((%clauses :initform '() :initarg :clauses :accessor clauses)
;   (%accumulation-variable :initform nil :accessor accumulation-variable)
;   (%accumulation-list-tail :initform nil :accessor accumulation-list-tail)
;   (%accumulation-type :initform nil :accessor accumulation-type)))

;;; Create a list of clauses from the body of the LOOP form.
(define (parse-loop-body body)
  (let loop ((remaining-body body)
             (clauses '()))
    (if (null? remaining-body)
      (reverse clauses)
      (pidgin-destructuring-bind (success clause rest)
        (parse-clause remaining-body)
        (if success
          (loop rest (cons clause clauses))
          ;; FIXME: this is not the right error to signal.
          (error 'expected-keyword-but-found
                 :found (car rest)))))))
;;;; The terminology used here is that of the BNF grammar in the
;;;; dictionary description of the loop macro in the HyperSpec.  It is
;;;; not the same as the terminology used in the section 6.1.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Common classes.

;;; The base class of all clauses.
(defclass clause () ())

;;; Mixin for clauses that accept `AND'.
(defclass subclauses-mixin ()
  (subclauses)
  ;;; Method on WRAP-CLAUSE specialized to clause types that admit
  ;;; subclauses.  This method overrides the default method above.  It
  ;;; wraps each subclause individually, and then wraps the result in
  ;;; the initial bindings for the entire clause.
  (wrap-clause (clause inner-form)
    (let ((result inner-form))
      (map (lambda (subclause)
              (set! result (wrap-subclause subclause result)))
            (reverse (clause 'subclauses)))
      `(let ,(initial-bindings clause)
         ,result))))

;;; Mixin for clauses and subclauses that take
;;; a VAR-SPEC and a TYPE-SPEC.
(defclass var-and-type-spec-mixin ()
  (var-spec type-spec))

;;; Mixin for clauses that take a list of compound forms.
(defclass compound-forms-mixin ()
  (forms))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Mixin for clauses that make the loop return a value.

(defclass loop-return-clause-mixin () ())

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Mixin for clauses that has an implicit IT argument.

(defclass it-mixin () ())

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Mixin for clauses that has an explicit form argument.

(defclass form-mixin ()
  (form))
(define (tail-variable head-variable)
  (let ((result (*tail-variables* head-variable)))
    (unless result
      (set! result (gensym))
      (set! (*tail-variables* head-variable) result))
    result))

(define (accumulation-bindings clauses)
  (let* ((descriptors
           (apply append
                  (map accumulation-variables clauses)))
         (equal-fun (lambda (d1 d2)
                      (and (eq? (car d1) (car d2))
                           (eq? (cadr d1) (cadr d2)))))
         (unique (remove-duplicates descriptors equal-fun)))
    (let loop ((unique unique))
      (if (null? unique)
        '()
        (let ((name (caar unique))
              (category (cadar unique))
              (type (caddar unique)))
          (let ((initial-value (cond ((eq? category 'count/sum) (car (arithmetic-value-and-type type))) ;(coerce 0 type)
                                     ((eq? category 'always/never) #t)
                                     (#t ''()))))
            (append
              (if (not name)
                `((,*accumulation-variable* ,initial-value))
                `((,name ,initial-value)))
              (if (eq? category 'list)
                (if (not name)
                  `((,*list-tail-accumulation-variable* '()))
                  `((,(tail-variable name) '())))
                '())
              (loop (cdr unique)))))))))

(define *clause* #f)
(define (prologue-body-epilogue clauses end-tag)
  (let ((start-tag (gensym)))
    (transform-tagbody
        `((begin ,@(map (lambda (clause)
                          (prologue-form clause end-tag))
                        clauses))
          ,start-tag
          (begin ,@(map (lambda (clause)
                          (body-form clause end-tag))
                        clauses))
          (begin ,@(map (lambda (clause)
                          (termination-form clause end-tag))
                        clauses))
          (begin ,@(map step-form clauses))
          (,start-tag)
          ,end-tag
          (begin ,@(map epilogue-form clauses)
                 (,*loop-return-sym*
                   ,*accumulation-variable*))))))

;;; Process all clauses by first computing the prologue, the body, and
;;; the epilogue, and then applying the clause-specific wrapper for
;;; each clause to the result.
(define (do-clauses all-clauses end-tag)
  (let ((result (prologue-body-epilogue all-clauses end-tag)))
    (map (lambda (clause)
           (set! result (wrap-clause clause result)))
         (reverse all-clauses))
    result))

(define (expand-clauses all-clauses end-tag)
  (let ((acc (accumulation-bindings all-clauses)))
    `(let (,@(if (member *accumulation-variable* (map car acc))
                 '()
                 `((,*accumulation-variable* '()))) ;*accumulation-variable* was nil originally; is '() right?
           , at acc)
       ,(do-clauses all-clauses end-tag))))

(define (expand-body loop-body)
  (if (every pair? loop-body)
      (let ((tag (gensym)))
        `(call-with-exit
           (letrec ((,tag (lambda (return)
                            , at loop-body
                            (,tag return))))
             ,tag)))
      (let ((clauses (parse-loop-body loop-body))
            (end-tag (gensym)))
        (analyze-clauses clauses)
        (let-temporarily ((*loop-name* (if (type? (car clauses) 'name-clause)
                                         ((car clauses) 'name)
                                         #f))
                          (*loop-return-sym* (gensym))
                          (*accumulation-variable* (gensym))
                          (*list-tail-accumulation-variable* (gensym))
                          (*tail-variables* (make-hash-table 8 eq?)))
          ; todo incorporate *loop-name* to allow named return
          `(call-with-exit
             (lambda (return)
               (call-with-exit
                 (lambda (,*loop-return-sym*)
                   (let ((loop-finish (macro () `(,',end-tag))))
                     ,(expand-clauses clauses end-tag))))))))))
;;; In the dictionary entry for LOOP, the HyperSpec says:
;;;
;;;   main-clause ::= unconditional |
;;;                   accumulation |
;;;                   conditional |
;;;                   termination-test |
;;;                   initial-final
;;;
;;; Here, we exclude initial-final.  The reason for that is that
;;; initial-final is also one of the possibilities for a
;;; variable-clause, and the reason for this "multiple inheritance" is
;;; so that the LOOP macro syntax can be defined to have the syntax:
;;;
;;;   loop [name-clause] {variable-clause}* {main-clause}*
;;;
;;; which then allows for INITIALLY and FINALLY clauses to occur
;;; anywhere after the name-clause.
;;;
;;; What we do here is to treat INITIALLY and FINALLY specially, so
;;; that they are neither main clauses nor variable clauses.
;;; Therefore, here, we have:
;;;
;;;   main-clause ::= unconditional |
;;;                   accumulation |
;;;                   conditional |
;;;                   termination-test
;;;
;;; Furthermore, the HyperSpec defines selectable-clause like this:
;;;
;;;   selectable-clause ::= unconditional | accumulation | conditional
;;;
;;; so we can say:
;;;
;;;    main-clause ::= selectable-clause | termination-test

(defclass main-clause (clause) ())
;;; In the dictionary entry for LOOP, the HyperSpec says:
;;;
;;;   variable-clause ::= with-clause | initial-final | for-as-clause
;;;
;;; Here, we exclude initial-final.  The reason for that is that
;;; initial-final is also one of the possibilities for a
;;; main-clause, and the reason for this "multiple inheritance" is
;;; so that the LOOP macro syntax can be defined to have the syntax:
;;;
;;;   loop [name-clause] {variable-clause}* {main-clause}*
;;;
;;; which then allows for INITIALLY and FINALLY clauses to occur
;;; anywhere after the name-clause.
;;;
;;; What we do here is to treat INITIALLY and FINALLY specially, so
;;; that they are neither main clauses nor variable clauses.
;;; Therefore, here, we have:
;;;
;;;   variable-clause ::= with-clause | for-as-clause

(defclass variable-clause (clause) ()
  ;;; No variable clause defines any accumulation variables
  (accumulation-variables (clause)
    '()))
;;; Recall that in the dictionary entry for LOOP, the HyperSpec says:
;;;
;;;   main-clause ::= unconditional |
;;;                   accumulation |
;;;                   conditional |
;;;                   termination-test |
;;;                   initial-final
;;;
;;; Though here, we exclude initial-final so that we have:
;;;
;;;   main-clause ::= unconditional |
;;;                   accumulation |
;;;                   conditional |
;;;                   termination-test
;;;
;;; Furthermore, the HyperSpec defines selectable-clause like this:
;;;
;;;   selectable-clause ::= unconditional | accumulation | conditional
;;;
;;; so we can say:
;;;
;;;    main-clause ::= selectable-clause | termination-test

(defclass selectable-clause (main-clause) ()
  (bound-variables (clause)
    '()))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser selectable-clause-parser
  (alternative do-clause-parser
               return-clause-parser
               collect-clause-parser
               append-clause-parser
               nconc-clause-parser
               count-clause-parser
               sum-clause-parser
               maximize-clause-parser
               minimize-clause-parser
               conditional-clause-parser))

(define-parser and-selectable-clause-parser
  (consecutive (lambda (and selectable-clause)
                 selectable-clause)
               (keyword-parser 'and)
               selectable-clause-parser))
(defclass unconditional-clause (selectable-clause) ())
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Accumulation clauses

(defclass accumulation-clause (selectable-clause)
  ;;; The methods on ACCUMULATION-VARIABLES call the function INTO-VAR
  ;;; on the clause in order to obtain the first element of each
  ;;; accumulation variable descriptor.  For clauses that have
  ;;; INTO-MIXIN as a superclass, the variable is stored in a slot.
  ;;; This method defines the default method to be used for all other
  ;;; accumulation clauses.
  ((into-var #f))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Method on ACCUMULATION-VARIABLES, valid for all accumulation
  ;;; clauses.

  (accumulation-variables (clause)
    `((,(clause 'into-var)
       ,(clause 'accumulation-category)
       ,(clause 'type-spec)))))

;;; We define three different accumulation CATEGORIES, each identified
;;; by a symbol: LIST, COUNT/SUM, and MAX/MIN.  Accumulation clauses
;;; within a category are compatible in that they can be mixed, even
;;; when they accumulate into the same variable.  This generic
;;; function takes an accumulation clause and returns the category.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; LIST-ACCUMULATION-CLAUSE.
;;;
;;; This class is the superclass of the list accumulation clauses:
;;; COLLECT-CLAUSE, APPEND-CLAUSE, and NCONC-CLAUSE.
;;;

(defclass list-accumulation-clause (accumulation-clause)
  ((accumulation-category 'list)
   ;;; The methods on ACCUMULATION-VARIABLES call the function TYPE-SPEC
   ;;; on the clause in order to obtain the third element of each
   ;;; accumulation variable descriptor.  For the numeric accumulation
   ;;; clauses, the type is stored in a slot.  For the list accumulation
   ;;; clauses, we always want to return the type LIST.
   (type-spec 'list)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; NUMERIC-ACCUMULATION-CLAUSE.

(defclass numeric-accumulation-clause (accumulation-clause)
  ((type-spec 't)))

(defclass count/sum-accumulation-clause (numeric-accumulation-clause)
  ((accumulation-category 'count/sum)))

(defclass max/min-accumulation-clause (numeric-accumulation-clause)
  ((accumulation-category 'max/min)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Mixin class for INTO clause variants.

(defclass into-mixin ()
  ((into-var #f)))
;;; We define a class that is the root class of all termination-test
;;; clauses.  Recall that a termination-test clause is a main clause,
;;; and that the HyperSpec defines TERMINATION-TEST as follows:
;;;
;;;   termination-test ::= while form |
;;;                        until form |
;;;                        repeat form |
;;;                        always form |
;;;                        never form |
;;;                        thereis form

(defclass termination-test-clause (main-clause) ()
  ;;; The termination-test clauses do not bind any variables.
  (bound-variables (clause) '())
  (accumulation-variables (clause) '()))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser for d-var-spec.

;;; A d-var-spec is a is a destructuring variable specifier:
;;;
;;;    d-var-spec ::= simple-var | nil | (d-var-spec . d-var-spec)
;;;
;;; where simple-var is a symbol (a name of a variable).
;;;

;;; Return true if and only if the argument is a valid d-var-spec, in
;;; other words if it is a tree of CONS cells where the leaves are
;;; symbols.
(define (d-var-spec-p object)
  (or (symbol? object)
      (and (pair? object)
           (d-var-spec-p (car object))
           (d-var-spec-p (cdr object)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser

(define-parser simple-type-spec-parser
  (lambda (tokens)
    (if (and (not (null? tokens))
             (member (car tokens) '(fixnum float t nil)))
        (list #t
                (car tokens)
                (cdr tokens))
        (list #f #f tokens))))

(define-parser destructured-type-spec-parser
  (consecutive (lambda (of-type tree)
                 tree)
               (keyword-parser 'of-type)
               anything-parser))

(define-parser type-spec-parser
  (alternative simple-type-spec-parser destructured-type-spec-parser))

(define-parser optional-type-spec-parser
  (optional #f type-spec-parser))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Clause NAME-CLAUSE.
;;;
;;; A NAME-CLAUSE is a clause that gives a name to the loop.  It
;;; translates to a block name, so that RETURN-FROM can be used to
;;; exit the loop.  By default, the name of the loop is nil.
;;;
;;; The name-clause is optional, and if present, must be the first one
;;; in the body.  The syntax is:
;;;
;;;    NAMED name
;;;
;;; where name is a symbol.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser.

(define-parser name-clause-parser
  (consecutive (lambda (named name)
                 (let ((name name)
                       (bound-variables (constantly '()))
                       (accumulation-variables (constantly '())))
                   (curlet)))
               (keyword-parser 'named)
               (singleton identity symbol?)))

(add-clause-parser name-clause-parser)
;;;; Clause INITIAL-CLAUSE.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Class INITIAL-CLAUSE.
;;;
;;; An INITIAL clause does not exist as a separate grammar item in
;;; the HyperSpec, but we define it here anyway.  The syntax is:
;;;
;;;    initial-clause ::= initially compound-form+

(defclass initial-clause (clause)
  (form)

  ;;; The initial clause does not bind any variables.
  (bound-variables (clause) '())
  (accumulation-variables (clause) '())

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute prologue-form.

  (prologue-form (clause end-tag)
    (clause 'form)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser

(define-parser initial-clause-parser
  (consecutive (lambda (initially compound+)
                 (make-instance 'initial-clause
                   :form compound+))
               (keyword-parser 'initially)
               compound+))

(add-clause-parser initial-clause-parser)
;;;; Clause FINAL-CLAUSE.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Class FINAL-CLAUSE.
;;;
;;; An FINAL clause does not exist as a separate grammar item in
;;; the HyperSpec, but we define it here anyway.  The syntax is:
;;;
;;;    final-clause ::= finally compound-form+

(defclass final-clause (clause)
  (form)

  ;;; The final clause does not bind any variables.
  (bound-variables (clause) '())
  (accumulation-variables (clause) '())

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute epilogue.

  (epilogue-form (clause)
    (clause 'form)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser

(define-parser final-clause-parser
  (consecutive (lambda (finally compound+)
                 (make-instance 'final-clause
                   :form compound+))
               (keyword-parser 'finally)
               compound+))

(add-clause-parser final-clause-parser)
;;; Clause WITH-CLAUSE.
;;;
;;; A WITH-CLAUSE allows the creation of local variables.  It is
;;; executed once.
;;;
;;; The syntax of a with-clause is:
;;;
;;;    with-clause ::= WITH var1 [type-spec] [= form1]
;;;                    {AND var2 [type-spec] [= form2]}*
;;;
;;; where var1 and var2 are destructuring variable specifiers
;;; (d-var-spec) allowing multiple local variables to be created in a
;;; single with-clause by destructuring the value of the corresponding
;;; form.
;;;
;;; When there are several consecutive with-clause, the execution is
;;; done sequentially, so that variables created in one with-clause
;;; can be used in the forms of subsequent with-clauses.  If parallel
;;; creation of variables is wanted, then the with-clause can be
;;; followed by one or more and-clauses.
;;;
;;; The (destructuring) type specifier is optional.  If no type
;;; specifier is given, it is as if t was given.
;;;
;;; The initialization form is optional.  If there is a corresponding
;;; type specifier for a variable, but no initialization form, then
;;; the variable is initialized to a value that is appropriate for the
;;; type.  In particular, for the type t the value is nil, for the
;;; type number, the value is 0, and for the type float, the value is
;;; 0.0.




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Class WITH-CLAUSE.
;;;

(defclass with-clause (variable-clause subclauses-mixin) ()
  (bound-variables (clause)
    (apply append (map bound-variables (clause 'subclauses))))
  (initial-bindings (clause)
    (apply append (map initial-bindings (clause 'subclauses)))))

(defclass with-subclause ()
  (var-spec
   type-spec
   ;; This slot contains a copy of the tree contained in the VAR-SPEC
   ;; slot except that the non-NIL leaves have been replaced by
   ;; GENSYMs.
   temp-vars
   ;; This slot contains a list of pairs.  Each pair is a CONS cell
   ;; where the CAR is a variable in VAR-SPEC and the CDR is the
   ;; corresponding variable in TEMP-VARS.
   dictionary
   ;;; The default form is NIL.
   (form '()))

  (bound-variables (subclause)
    (map car
         (extract-variables (subclause 'var-spec) #f)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the declarations.

  (declarations (clause)
    (apply append (map declarations (clause 'subclauses)))))

(defclass with-subclause-no-form (with-subclause) ()
  (wrap-subclause (subclause inner-form)
    (let* ((vars-and-types
             (extract-variables (subclause 'var-spec) (subclause 'type-spec)))
           (vars-and-values
             (map (lambda (vt)
                    (list (car vt) (case (cadr vt)
                                     ((fixnum) 0)
                                     ((float) 0.0)
                                     (else #<undefined>))))
                  vars-and-types))) ;undefined was nil in cl
      `(let ,vars-and-values
         ,inner-form))))

(defclass with-subclause-with-form (with-subclause)
  (form
   (form-var (gensym)))

  (initial-bindings (clause)
    `((,(clause 'form-var) ,(clause 'form))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the subclause wrapper.

  (wrap-subclause (subclause inner-form)
    `(let* ,(destructure-variables (subclause 'var-spec) (subclause 'form-var))
       ,inner-form)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

;;; Parser for var [type-spec] = form
;;; We try this parser first.
(define-parser with-subclause-type-1-parser
  (consecutive (lambda (var-spec type-spec = form)
                 (pidgin-destructuring-bind (temp-vars dictionary)
                      (fresh-variables var-spec)
                    (make-instance 'with-subclause-with-form
                      :var-spec var-spec
                      :type-spec type-spec
                      :temp-vars temp-vars
                      :dictionary dictionary
                      :form form)))
               ;; Accept anything for now.  Analyze later.
               anything-parser
               optional-type-spec-parser
               (keyword-parser '=)
               anything-parser))

;;; Parser for var [type-spec]
(define-parser with-subclause-type-2-parser
  (consecutive (lambda (var-spec type-spec)
                 (pidgin-destructuring-bind (temp-vars dictionary)
                      (fresh-variables var-spec)
                   (make-instance 'with-subclause-no-form
                     :var-spec var-spec
                     :type-spec type-spec
                     :temp-vars temp-vars
                     :dictionary dictionary)))
               ;; Accept anything for now.  Analyze later.
               anything-parser
               optional-type-spec-parser))

;;; Parser for any type of with subclause without the leading keyword
(define-parser with-subclause-no-keyword-parser
  (alternative with-subclause-type-1-parser
               with-subclause-type-2-parser))

;;; Parser for the with subclause starting with the AND keyword.
(define-parser with-subclause-and-parser
  (consecutive (lambda (and subclause)
                 subclause)
               (keyword-parser 'and)
               with-subclause-no-keyword-parser))

;;; Parser for a with clause
(define-parser with-clause-parser
  (consecutive (lambda (with first rest)
                 (make-instance 'with-clause
                   :subclauses (cons first rest)))
               (keyword-parser 'with)
               with-subclause-no-keyword-parser
               (repeat* list
                        with-subclause-and-parser)))

(add-clause-parser with-clause-parser)
;;;; Clause RETURN-CLAUSE.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Class RETURN-CLAUSE.
;;;
;;; An RETURN clause does not exist as a separate grammar item in
;;; the HyperSpec, but we define it here anyway.  The syntax is:
;;;
;;;    return-clause ::= return {form | it}

(defclass return-clause (unconditional-clause)
  ()
  (accumulation-variables (clause)
    '()))


(defclass return-it-clause (return-clause) ()
  (body-form (clause end-tag)
    (unless *it-var* (error "need an iteration variable in order to 'return it'"))
    `(,*loop-return-sym* ,*it-var*)))

(defclass return-form-clause (return-clause)
  (form)
  (body-form (clause end-tag)
    `(,*loop-return-sym* ,(clause 'form))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser

(define-parser return-it-clause-parser
  (consecutive (lambda (return it)
                 (make-instance 'return-it-clause))
               (keyword-parser 'return)
               (keyword-parser 'it)))

(define-parser return-form-clause-parser
  (consecutive (lambda (return form)
                 (make-instance 'return-form-clause
                   :form form))
               (keyword-parser 'return)
               anything-parser))

(define-parser return-clause-parser
  (alternative return-it-clause-parser
               return-form-clause-parser))

(add-clause-parser return-clause-parser)
;;;; Clause DO-CLAUSE.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Class DO-CLAUSE.
;;;
;;; An DO clause does not exist as a separate grammar item in
;;; the HyperSpec, but we define it here anyway.  The syntax is:
;;;
;;;    do-clause ::= do compound-form+

(defclass do-clause (unconditional-clause)
  (body)
  (accumulation-variables (clause)
    '())

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the body-form.
  (body-form (clause end-tag)
    (clause 'body)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser

(define-parser do-clause-parser
  (consecutive (lambda (do compound+)
                 (make-instance 'do-clause
                   :body compound+))
               (alternative (keyword-parser 'do)
                            (keyword-parser 'doing))
               compound+))

(add-clause-parser do-clause-parser)
(defclass collect-clause (list-accumulation-clause) ())

(defclass collect-it-clause (collect-clause it-mixin)
  ()

  (body-form (clause end-tag)
    `(if (null? ,*list-tail-accumulation-variable*)
         (begin (set! ,*list-tail-accumulation-variable*
                      (list ,*it-var*))
                (set! ,*accumulation-variable*
                      ,*list-tail-accumulation-variable*))
         (begin (set! ,*list-tail-accumulation-variable*
                      (,last ,*list-tail-accumulation-variable*))
                (set-cdr! ,*list-tail-accumulation-variable*
                          (list ,*it-var*))))))

(defclass collect-form-clause (collect-clause form-mixin)
  ()

  (body-form (clause end-tag)
    `(if (null? ,*list-tail-accumulation-variable*)
       (begin (set! ,*list-tail-accumulation-variable*
                    (list-values ,(clause 'form)))
              (set! ,*accumulation-variable*
                    ,*list-tail-accumulation-variable*))
       (begin (set! ,*list-tail-accumulation-variable*
                    (,last ,*list-tail-accumulation-variable*))
              (set-cdr! ,*list-tail-accumulation-variable*
                        (list-values ,(clause 'form)))))))

(defclass collect-it-into-clause (into-mixin collect-clause it-mixin)
  ()

  (body-form (clause end-tag)
    `(if (null? ,(tail-variable (clause 'into-var)))
         (begin (set! ,(tail-variable (clause 'into-var))
                      (list ,*it-var*))
                (set! ,(clause 'into-var)
                      ,(tail-variable (clause 'into-var))))
         (begin (set! ,(tail-variable (clause 'into-var))
                      (,last ,(tail-variable (clause 'into-var))))
                (set-cdr! ,(tail-variable (clause 'into-var))
                          (list ,*it-var*))))))

(defclass collect-form-into-clause (into-mixin collect-clause form-mixin)
  ()

  (body-form (clause end-tag)
    `(if (null? ,(tail-variable (clause 'into-var)))
       (begin (set! ,(tail-variable (clause 'into-var))
                    (list-values ,(clause 'form)))
              (set! ,(clause 'into-var)
                    ,(tail-variable (clause 'into-var))))
       (begin (set! ,(tail-variable (clause 'into-var))
                    (,last ,(tail-variable (clause 'into-var))))
              (set-cdr! ,(tail-variable (clause 'into-var))
                        (list-values ,(clause 'form)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser collect-it-into-clause-parser
  (consecutive (lambda (collect it into var)
                 (make-instance 'collect-it-into-clause
                   :into-var var))
               (alternative (keyword-parser 'collect)
                            (keyword-parser 'collecting))
               (keyword-parser 'it)
               (keyword-parser 'into)
               (singleton identity
                          symbol?)))

(define-parser collect-it-clause-parser
  (consecutive (lambda (collect it)
                 (make-instance 'collect-it-clause))
               (alternative (keyword-parser 'collect)
                            (keyword-parser 'collecting))
               (keyword-parser 'it)))

(define-parser collect-form-into-clause-parser
  (consecutive (lambda (collect form into var)
                 (make-instance 'collect-form-into-clause
                   :form form
                   :into-var var))
               (alternative (keyword-parser 'collect)
                            (keyword-parser 'collecting))
               anything-parser
               (keyword-parser 'into)
               (singleton identity
                          symbol?)))

(define-parser collect-form-clause-parser
  (consecutive (lambda (collect form)
                 (make-instance 'collect-form-clause
                   :form form))
               (alternative (keyword-parser 'collect)
                            (keyword-parser 'collecting))
               anything-parser))

(define-parser collect-clause-parser
  (alternative collect-it-into-clause-parser
               collect-it-clause-parser
               collect-form-into-clause-parser
               collect-form-clause-parser))

(add-clause-parser collect-clause-parser)
(defclass append-clause (list-accumulation-clause) ())

(defclass append-it-clause (append-clause it-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,*list-tail-accumulation-variable*)
         (begin (set! ,*accumulation-variable*
                      (,copy-list ,*it-var*))
                (set! ,*list-tail-accumulation-variable*
                      (,last ,*accumulation-variable*)))
         (begin (set! ,*list-tail-accumulation-variable*
                      (,last ,*list-tail-accumulation-variable*))
                (set-cdr! ,*list-tail-accumulation-variable*
                        (,copy-list ,*it-var*))))))

(defclass append-form-clause (append-clause form-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,*list-tail-accumulation-variable*)
         (begin (set! ,*accumulation-variable*
                      (,copy-list ,(clause 'form)))
                (set! ,*list-tail-accumulation-variable*
                      (,last ,*accumulation-variable*)))
         (begin (set! ,*list-tail-accumulation-variable*
                      (,last ,*list-tail-accumulation-variable*))
                (set-cdr! ,*list-tail-accumulation-variable*
                        (,copy-list ,(clause 'form)))))))

(defclass append-it-into-clause (into-mixin append-clause it-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,(tail-variable (clause 'into-var)))
         (begin (set! ,(clause 'into-var)
                      (,copy-list ,*it-var*))
                (set! ,(tail-variable (clause 'into-var))
                      (,last ,(clause 'into-var))))
         (begin (set! ,(tail-variable (clause 'into-var))
                      (,last ,(tail-variable (clause 'into-var))))
                (set-cdr! ,(tail-variable (clause 'into-var))
                        (,copy-list ,*it-var*))))))

(defclass append-form-into-clause (into-mixin append-clause form-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,(tail-variable (clause 'into-var)))
         (begin (set! ,(clause 'into-var)
                      (,copy-list ,(clause 'form)))
                (set! ,(tail-variable (clause 'into-var))
                      (,last ,(clause 'into-var))))
         (begin (set! ,(tail-variable (clause 'into-var))
                      (,last ,(tail-variable (clause 'into-var))))
                (set-cdr! ,(tail-variable (clause 'into-var))
                        (,copy-list ,(clause 'form)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser append-it-into-clause-parser
  (consecutive (lambda (append it into var)
                 (make-instance 'append-it-into-clause
                   :into-var var))
               (alternative (keyword-parser 'append)
                            (keyword-parser 'appending))
               (keyword-parser 'it)
               (keyword-parser 'into)
               (singleton identity symbol?)))

(define-parser append-it-clause-parser
  (consecutive (lambda (append it)
                 (make-instance 'append-it-clause))
               (alternative (keyword-parser 'append)
                            (keyword-parser 'appending))
               (keyword-parser 'it)))

(define-parser append-form-into-clause-parser
  (consecutive (lambda (append form into var)
                 (make-instance 'append-form-into-clause
                   :form form
                   :into-var var))
               (alternative (keyword-parser 'append)
                            (keyword-parser 'appending))
               anything-parser
               (keyword-parser 'into)
               (singleton identity symbol?)))

(define-parser append-form-clause-parser
  (consecutive (lambda (append form)
                 (make-instance 'append-form-clause
                   :form form))
               (alternative (keyword-parser 'append)
                            (keyword-parser 'appending))
               anything-parser))

(define-parser append-clause-parser
  (alternative append-it-into-clause-parser
               append-it-clause-parser
               append-form-into-clause-parser
               append-form-clause-parser))

(add-clause-parser append-clause-parser)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Compute body-form.




(defclass nconc-clause (list-accumulation-clause) ())

(defclass nconc-it-clause (nconc-clause it-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,*list-tail-accumulation-variable*)
         (begin (set! ,*accumulation-variable*
                      ,*it-var*)
                (set! ,*list-tail-accumulation-variable*
                      (,last ,*accumulation-variable*)))
         (begin (set! ,*list-tail-accumulation-variable*
                      (,last ,*list-tail-accumulation-variable*))
                (set-cdr! ,*list-tail-accumulation-variable*
                        ,*it-var*)))))

(defclass nconc-form-clause (nconc-clause form-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,*list-tail-accumulation-variable*)
         (begin (set! ,*accumulation-variable*
                      ,(clause 'form))
                (set! ,*list-tail-accumulation-variable*
                      (,last ,*accumulation-variable*)))
         (begin (set! ,*list-tail-accumulation-variable*
                      (,last ,*list-tail-accumulation-variable*))
                (set-cdr! ,*list-tail-accumulation-variable*
                        ,(clause 'form))))))

(defclass nconc-it-into-clause (into-mixin nconc-clause it-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,(tail-variable (clause 'into-var)))
         (begin (set! ,(clause 'into-var)
                      ,*it-var*)
                (set! ,(tail-variable (clause 'into-var))
                      (,last ,(clause 'into-var))))
         (begin (set! ,(tail-variable (clause 'into-var))
                      (,last ,(tail-variable (clause 'into-var))))
                (set-cdr! ,(tail-variable (clause 'into-var))
                        ,*it-var*)))))

(defclass nconc-form-into-clause (into-mixin nconc-clause form-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,(tail-variable (clause 'into-var)))
         (begin (set! ,(clause 'into-var)
                      ,(clause 'form))
                (set! ,(tail-variable (clause 'into-var))
                      (,last ,(clause 'into-var))))
         (begin (set! ,(tail-variable (clause 'into-var))
                      (,last ,(tail-variable (clause 'into-var))))
                (set-cdr! ,(tail-variable (clause 'into-var))
                          ,(clause 'form))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser nconc-it-into-clause-parser
  (consecutive (lambda (nconc it into var)
                 (make-instance 'nconc-it-into-clause
                   :into-var var))
               (alternative (keyword-parser 'nconc)
                            (keyword-parser 'nconcing))
               (keyword-parser 'it)
               (keyword-parser 'into)
               (singleton identity symbol?)))

(define-parser nconc-it-clause-parser
  (consecutive (lambda (nconc it)
                 (make-instance 'nconc-it-clause))
               (alternative (keyword-parser 'nconc)
                            (keyword-parser 'nconcing))
               (keyword-parser 'it)))

(define-parser nconc-form-into-clause-parser
  (consecutive (lambda (nconc form into var)
                 (make-instance 'nconc-form-into-clause
                   :form form
                   :into-var var))
               (alternative (keyword-parser 'nconc)
                            (keyword-parser 'nconcing))
               anything-parser
               (keyword-parser 'into)
               (singleton identity symbol?)))

(define-parser nconc-form-clause-parser
  (consecutive (lambda (nconc form)
                 (make-instance 'nconc-form-clause
                   :form form))
               (alternative (keyword-parser 'nconc)
                            (keyword-parser 'nconcing))
               anything-parser))

(define-parser nconc-clause-parser
  (alternative nconc-it-into-clause-parser
               nconc-it-clause-parser
               nconc-form-into-clause-parser
               nconc-form-clause-parser))

(add-clause-parser nconc-clause-parser)
(defclass count-clause (count/sum-accumulation-clause) ())

(defclass count-it-clause (count-clause it-mixin) ()
  (body-form (clause end-tag)
    `(when ,*it-var*
       (set! ,*accumulation-variable*
             (+ 1 ,*accumulation-variable*)))))

(defclass count-form-clause (count-clause form-mixin) ()
  (body-form (clause end-tag)
    `(when ,(clause 'form)
       (set! ,*accumulation-variable*
             (+ 1 ,*accumulation-variable*)))))

(defclass count-it-into-clause (into-mixin count-clause it-mixin) ()
  (body-form (clause end-tag)
    `(when ,*it-var*
       (set! ,(clause 'into-var)
             (+ 1 ,(clause 'into-var))))))

(defclass count-form-into-clause (into-mixin count-clause form-mixin) ()
  (body-form (clause end-tag)
    `(when ,(clause 'form)
       (set! ,(clause 'into-var)
             (+ 1 ,(clause 'into-var))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser count-it-into-clause-parser
  (consecutive (lambda (count it into var type-spec)
                 (make-instance 'count-it-into-clause
                   :into-var var
                   :type-spec type-spec))
               (alternative (keyword-parser 'count)
                            (keyword-parser 'counting))
               (keyword-parser 'it)
               (keyword-parser 'into)
               (singleton identity
                          symbol?)
               optional-type-spec-parser))

(define-parser count-it-clause-parser
  (consecutive (lambda (count it type-spec)
                 (make-instance 'count-it-clause
                   :type-spec type-spec))
               (alternative (keyword-parser 'count)
                            (keyword-parser 'counting))
               (keyword-parser 'it)
               optional-type-spec-parser))

(define-parser count-form-into-clause-parser
  (consecutive (lambda (count form into var type-spec)
                 (make-instance 'count-form-into-clause
                   :form form
                   :into-var var
                   :type-spec type-spec))
               (alternative (keyword-parser 'count)
                            (keyword-parser 'counting))
               anything-parser
               (keyword-parser 'into)
               (singleton identity
                          symbol?)
               optional-type-spec-parser))

(define-parser count-form-clause-parser
  (consecutive (lambda (count form type-spec)
                 (make-instance 'count-form-clause
                   :form form
                   :type-spec type-spec))
               (alternative (keyword-parser 'count)
                            (keyword-parser 'counting))
               anything-parser
               optional-type-spec-parser))

(define-parser count-clause-parser
  (alternative count-it-into-clause-parser
               count-it-clause-parser
               count-form-into-clause-parser
               count-form-clause-parser))

(add-clause-parser count-clause-parser)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Compute the BODY-FORM.
(defclass sum-clause (count/sum-accumulation-clause) ())

(defclass sum-it-clause (sum-clause it-mixin) ()
  (body-form (clause end-tag)
    `(set! ,*accumulation-variable*
           (,sum ,*accumulation-variable* ,*it-var*))))

(defclass sum-form-clause (sum-clause form-mixin) ()
  (body-form (clause end-tag)
      `(set! ,*accumulation-variable*
         (apply ,sum ,*accumulation-variable* (list-values ,(clause 'form))))))

(defclass sum-it-into-clause (into-mixin sum-clause it-mixin) ()
  (body-form (clause end-tag)
    `(set! ,(clause 'into-var)
           (,sum ,(clause 'into-var) ,*it-var*))))

(defclass sum-form-into-clause (into-mixin sum-clause form-mixin) ()
  (body-form (clause end-tag)
    `(set! ,(clause 'into-var)
           (apply ,sum ,(clause 'into-var) (list-values ,(clause 'form))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser sum-it-into-clause-parser
  (consecutive (lambda (sum it into var type-spec)
                 (make-instance 'sum-it-into-clause
                   :into-var var
                   :type-spec type-spec))
               (alternative (keyword-parser 'sum)
                            (keyword-parser 'summing))
               (keyword-parser 'it)
               (keyword-parser 'into)
               (singleton identity
                          symbol?)
               optional-type-spec-parser))

(define-parser sum-it-clause-parser
  (consecutive (lambda (sum it type-spec)
                 (make-instance 'sum-it-clause
                   :type-spec type-spec))
               (alternative (keyword-parser 'sum)
                            (keyword-parser 'summing))
               (keyword-parser 'it)
               optional-type-spec-parser))

(define-parser sum-form-into-clause-parser
  (consecutive (lambda (sum form into var type-spec)
                 (make-instance 'sum-form-into-clause
                   :form form
                   :into-var var
                   :type-spec type-spec))
               (alternative (keyword-parser 'sum)
                            (keyword-parser 'summing))
               anything-parser
               (keyword-parser 'into)
               (singleton identity
                          symbol?)
               optional-type-spec-parser))

(define-parser sum-form-clause-parser
  (consecutive (lambda (sum form type-spec)
                 (make-instance 'sum-form-clause
                   :form form
                   :type-spec type-spec))
               (alternative (keyword-parser 'sum)
                            (keyword-parser 'summing))
               anything-parser
               optional-type-spec-parser))

(define-parser sum-clause-parser
  (alternative sum-it-into-clause-parser
               sum-it-clause-parser
               sum-form-into-clause-parser
               sum-form-clause-parser))

(add-clause-parser sum-clause-parser)
(defclass maximize-clause (max/min-accumulation-clause) ())

(defclass maximize-it-clause (maximize-clause it-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,*accumulation-variable*)
         (set! ,*accumulation-variable* (,ensure-real ,*it-var* 'max-argument-must-be-real))
         (set! ,*accumulation-variable*
               (,maximize ,*accumulation-variable* ,*it-var*)))))

(defclass maximize-form-clause (maximize-clause form-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,*accumulation-variable*)
         (set! ,*accumulation-variable* (apply ,maximize -inf.0 (list-values ,(clause 'form))))
         (set! ,*accumulation-variable*
               (apply ,maximize ,*accumulation-variable* (list-values ,(clause 'form)))))))

(defclass maximize-it-into-clause (into-mixin maximize-clause it-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,(clause 'into-var))
         (set! ,(clause 'into-var) (,ensure-real ,*it-var* 'max-argument-must-be-real))
         (set! ,(clause 'into-var)
               (,maximize ,(clause 'into-var) ,*it-var*)))))

(defclass maximize-form-into-clause (into-mixin maximize-clause form-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,(clause 'into-var))
         (set! ,(clause 'into-var) (apply ,maximize -inf.0 (list-values ,(clause 'form))))
         (set! ,(clause 'into-var)
               (apply ,maximize ,(clause 'into-var) (list-values ,(clause 'form)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser maximize-it-into-clause-parser
  (consecutive (lambda (maximize it into var type-spec)
                 (make-instance 'maximize-it-into-clause
                   :into-var var
                   :type-spec type-spec))
               (alternative (keyword-parser 'maximize)
                            (keyword-parser 'maximizing))
               (keyword-parser 'it)
               (keyword-parser 'into)
               (singleton identity symbol?)
               optional-type-spec-parser))

(define-parser maximize-it-clause-parser
  (consecutive (lambda (maximize it type-spec)
                 (make-instance 'maximize-it-clause
                   :type-spec type-spec))
               (alternative (keyword-parser 'maximize)
                            (keyword-parser 'maximizing))
               (keyword-parser 'it)
               optional-type-spec-parser))

(define-parser maximize-form-into-clause-parser
  (consecutive (lambda (maximize form into var type-spec)
                 (make-instance 'maximize-form-into-clause
                   :form form
                   :into-var var
                   :type-spec type-spec))
               (alternative (keyword-parser 'maximize)
                            (keyword-parser 'maximizing))
               anything-parser
               (keyword-parser 'into)
               (singleton identity symbol?)
               optional-type-spec-parser))

(define-parser maximize-form-clause-parser
  (consecutive (lambda (maximize form type-spec)
                 (make-instance 'maximize-form-clause
                   :form form
                   :type-spec type-spec))
               (alternative (keyword-parser 'maximize)
                            (keyword-parser 'maximizing))
               anything-parser
               optional-type-spec-parser))

(define-parser maximize-clause-parser
  (alternative maximize-it-into-clause-parser
               maximize-it-clause-parser
               maximize-form-into-clause-parser
               maximize-form-clause-parser))

(add-clause-parser maximize-clause-parser)
(defclass minimize-clause (max/min-accumulation-clause) ())

(defclass minimize-it-clause (minimize-clause it-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,*accumulation-variable*)
         (set! ,*accumulation-variable* (,ensure-real ,*it-var* 'min-argument-must-be-real))
         (set! ,*accumulation-variable*
               (,minimize ,*accumulation-variable* ,*it-var*)))))

(defclass minimize-form-clause (minimize-clause form-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,*accumulation-variable*)
         (set! ,*accumulation-variable* (apply ,minimize +inf.0 (list-values ,(clause 'form))))
         (set! ,*accumulation-variable*
               (apply ,minimize ,*accumulation-variable* (list-values ,(clause 'form)))))))

(defclass minimize-it-into-clause (into-mixin minimize-clause it-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,(clause 'into-var))
         (set! ,(clause 'into-var) (,ensure-real ,*it-var* 'min-argument-must-be-real))
         (set! ,(clause 'into-var)
               (,minimize ,(clause 'into-var) ,*it-var*)))))

(defclass minimize-form-into-clause (into-mixin minimize-clause form-mixin) ()
  (body-form (clause end-tag)
    `(if (null? ,(clause 'into-var))
         (set! ,(clause 'into-var) (apply ,minimize +inf.0 (list-values ,(clause 'form))))
         (set! ,(clause 'into-var)
               (apply ,minimize ,(clause 'into-var) (list-values ,(clause 'form)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser minimize-it-into-clause-parser
  (consecutive (lambda (minimize it into var type-spec)
                 (make-instance 'minimize-it-into-clause
                   :into-var var
                   :type-spec type-spec))
               (alternative (keyword-parser 'minimize)
                            (keyword-parser 'minimizing))
               (keyword-parser 'it)
               (keyword-parser 'into)
               (singleton identity symbol?)
               optional-type-spec-parser))

(define-parser minimize-it-clause-parser
  (consecutive (lambda (minimize it type-spec)
                 (make-instance 'minimize-it-clause
                   :type-spec type-spec))
               (alternative (keyword-parser 'minimize)
                            (keyword-parser 'minimizing))
               (keyword-parser 'it)
               optional-type-spec-parser))

(define-parser minimize-form-into-clause-parser
  (consecutive (lambda (minimize form into var type-spec)
                 (make-instance 'minimize-form-into-clause
                   :form form
                   :into-var var
                   :type-spec type-spec))
               (alternative (keyword-parser 'minimize)
                            (keyword-parser 'minimizing))
               anything-parser
               (keyword-parser 'into)
               (singleton identity symbol?)
               optional-type-spec-parser))

(define-parser minimize-form-clause-parser
  (consecutive (lambda (minimize form type-spec)
                 (make-instance 'minimize-form-clause
                   :form form
                   :type-spec type-spec))
               (alternative (keyword-parser 'minimize)
                            (keyword-parser 'minimizing))
               anything-parser
               optional-type-spec-parser))

(define-parser minimize-clause-parser
  (alternative minimize-it-into-clause-parser
               minimize-it-clause-parser
               minimize-form-into-clause-parser
               minimize-form-clause-parser))

(add-clause-parser minimize-clause-parser)
(defclass conditional-clause (selectable-clause)
  (condition then-clauses else-clauses)

  ;;; A conditional clause does not introduce any bindings for any
  ;;; variables, so this method should return the empty list.
  (bound-variables (clause)
    '())

  (accumulation-variables (clause)
    (append (apply append
                    (map accumulation-variables (clause 'then-clauses)))
            (apply append
                    (map accumulation-variables (clause 'else-clauses)))))
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute body-form.

  (body-form (clause end-tag)
    (let-temporarily ((*it-var* (gensym)))
      `(let ((,*it-var* ,(clause 'condition)))
         (if ,*it-var*
             (begin
               ,@(map (lambda (clause)
                           (body-form clause end-tag))
                         (clause 'then-clauses)))
             (begin
               ,@(map (lambda (clause)
                           (body-form clause end-tag))
                         (clause 'else-clauses))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser then-or-else-parser
  (consecutive cons
               selectable-clause-parser
               (repeat* list
                        and-selectable-clause-parser)))
(define-parser if-else-end-clause-parser
  (consecutive (lambda (if form then-clauses else else-clauses end)
                 (make-instance 'conditional-clause
                   :condition form
                   :then-clauses then-clauses
                   :else-clauses else-clauses))
               (alternative (keyword-parser 'if)
                            (keyword-parser 'when))
               anything-parser
               then-or-else-parser
               (keyword-parser 'else)
               then-or-else-parser
               (keyword-parser 'end)))

(define-parser if-end-clause-parser
  (consecutive (lambda (if form then-clauses end)
                 (make-instance 'conditional-clause
                   :condition form
                   :then-clauses then-clauses
                   :else-clauses '()))
               (alternative (keyword-parser 'if)
                            (keyword-parser 'when))
               anything-parser
               then-or-else-parser
               (keyword-parser 'end)))

(define-parser if-else-clause-parser
  (consecutive (lambda (if form then-clauses else else-clauses)
                 (make-instance 'conditional-clause
                   :condition form
                   :then-clauses then-clauses
                   :else-clauses else-clauses))
               (alternative (keyword-parser 'if)
                            (keyword-parser 'when))
               anything-parser
               then-or-else-parser
               (keyword-parser 'else)
               then-or-else-parser))

(define-parser if-clause-parser
  (consecutive (lambda (if form then-clauses)
                 (make-instance 'conditional-clause
                   :condition form
                   :then-clauses then-clauses
                   :else-clauses '()))
               (alternative (keyword-parser 'if)
                            (keyword-parser 'when))
               anything-parser
               then-or-else-parser))

(define-parser if-when-parser
  (alternative if-else-end-clause-parser
               if-end-clause-parser
               if-else-clause-parser
               if-clause-parser))

(define-parser unless-else-end-clause-parser
  (consecutive (lambda (unless form else-clauses else then-clauses end)
                 (make-instance 'conditional-clause
                   :condition form
                   :then-clauses then-clauses
                   :else-clauses else-clauses))
               (keyword-parser 'unless)
               anything-parser
               then-or-else-parser
               (keyword-parser 'else)
               then-or-else-parser
               (keyword-parser 'end)))

(define-parser unless-end-clause-parser
  (consecutive (lambda (unless form else-clauses end)
                 (make-instance 'conditional-clause
                   :condition form
                   :then-clauses '()
                   :else-clauses else-clauses))
               (keyword-parser 'unless)
               anything-parser
               then-or-else-parser
               (keyword-parser 'end)))

(define-parser unless-else-clause-parser
  (consecutive (lambda (unless form else-clauses else then-clauses)
                 (make-instance 'conditional-clause
                   :condition form
                   :then-clauses then-clauses
                   :else-clauses else-clauses))
               (keyword-parser 'unless)
               anything-parser
               then-or-else-parser
               (keyword-parser 'else)
               then-or-else-parser))

(define-parser unless-clause-parser
  (consecutive (lambda (unless form else-clauses)
                 (make-instance 'conditional-clause
                   :condition form
                   :then-clauses '()
                   :else-clauses else-clauses))
               (alternative (keyword-parser 'unless)
                            (keyword-parser 'when))
               anything-parser
               then-or-else-parser))

(define-parser unless-parser
  (alternative unless-else-end-clause-parser
               unless-end-clause-parser
               unless-else-clause-parser
               unless-clause-parser))

(define-parser conditional-clause-parser
  (alternative if-when-parser
               unless-parser))

(add-clause-parser conditional-clause-parser)

(defclass while-clause (termination-test-clause)
  (form)

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the body-form

  (body-form (clause end-tag)
    `(unless ,(clause 'form)
       (,end-tag))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser while-clause-parser
  (consecutive (lambda (while form)
                 (make-instance 'while-clause
                   :form form))
               (keyword-parser 'while)
               anything-parser))

(add-clause-parser while-clause-parser)

(define-parser until-clause-parser
  (consecutive (lambda (until form)
                 (make-instance 'while-clause
                   :form `(not ,form)))
               (keyword-parser 'until)
               anything-parser))

(add-clause-parser until-clause-parser)
(defclass repeat-clause (termination-test-clause var-and-type-spec-mixin)
  (form
   (var-spec (gensym))
   (type-spec 'real))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the bindings.

  (initial-bindings (clause)
    `((,(clause 'var-spec) ,(clause 'form))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the declarations.

  (declarations (clause)
    '())

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the prologue-form.

  (prologue-form (clause end-tag)
    `(when (<= ,(clause 'var-spec) 0)
       (,end-tag)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the termination-form.

  (termination-form (clause end-tag)
    `(when (<= ,(clause 'var-spec) 1)
       (,end-tag)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the step-form.

  (step-form (clause)
    `(set! ,(clause 'var-spec) (- ,(clause 'var-spec) 1))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser repeat-clause-parser
  (consecutive (lambda (repeat form)
                 (make-instance 'repeat-clause :form form))
               (keyword-parser 'repeat)
               anything-parser))

(add-clause-parser repeat-clause-parser)
(defclass always-clause (termination-test-clause form-mixin) ()
  (accumulation-variables (clause)
    `((#f always/never t)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the body-form

  (body-form (clause end-tag)
    `(unless ,(clause 'form)
       (,*loop-return-sym* #f))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser always-clause-parser
  (consecutive (lambda (always form)
                 (make-instance 'always-clause
                   :form form))
               (keyword-parser 'always)
               anything-parser))

(add-clause-parser always-clause-parser)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser never-clause-parser
  (consecutive (lambda (never form)
                 (make-instance 'always-clause
                   :form (list not form)))
               (keyword-parser 'never)
               anything-parser))

(add-clause-parser never-clause-parser)
(defclass thereis-clause (termination-test-clause form-mixin) ()
  (accumulation-variables (clause)
    `((nil thereis t)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the body-form

  (body-form (clause end-tag)
    `(let ((temp ,(clause 'form)))
       (when temp
         (,*loop-return-sym* temp)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser thereis-clause-parser
  (consecutive (lambda (thereis form)
                 (make-instance 'thereis-clause
                   :form form))
               (keyword-parser 'thereis)
               anything-parser))

(add-clause-parser thereis-clause-parser)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Clause FOR-AS-CLAUSE.
;;;
;;; The HyperSpec says that a FOR-AS-CLAUSE has the following syntax:
;;;
;;;    for-as-clause ::= {for | as} for-as-subclause {and for-as-subclause}*
;;;    for-as-subclause::= for-as-arithmetic | for-as-in-list |
;;;                        for-as-on-list | for-as-equals-then |
;;;                        for-as-across | for-as-hash | for-as-package
;;;
;;; For the purpose of specialization, we need different names for the
;;; main clauses as well as for the subclauses, so we alter this
;;; grammar a bit and define it like this instead:
;;;
;;;    for-as-clause::=
;;;      for-as-arithmetic-clause | for-as-in-list-clause |
;;;      for-as-on-list-clause | for-as-equals-then-clause |
;;;      for-as-across-clause | for-as-hash-clause | for-as-package-clause
;;;
;;;    for-as-arithmetic-clause ::=
;;;      {for | as} for-as-arithmetic {and for-as-subclause}*
;;;
;;;    for-as-in-list-clause ::=
;;;      {for | as} for-as-in-list {and for-as-subclause}*
;;;
;;;    for-as-on-list-clause ::=
;;;      {for | as} for-as-on-list {and for-as-subclause}*
;;;
;;;    for-as-equals-then-clause ::=
;;;      {for | as} for-as-equals-then {and for-as-subclause}*
;;;
;;;    for-as-across-clause ::=
;;;      {for | as} for-as-across {and for-as-subclause}*
;;;
;;;    for-as-hash-clause ::=
;;;      {for | as} for-as-hash {and for-as-subclause}*
;;;
;;;    for-as-package-clause ::=
;;;      {for | as} for-as-package {and for-as-subclause}*

(defclass for-as-clause (variable-clause subclauses-mixin) ()
  (bound-variables (clause)
    (apply append
            (map bound-variables (clause 'subclauses))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the bindings.

  (initial-bindings (clause)
    (apply append (map initial-bindings (clause 'subclauses))))

  (final-bindings (clause)
    (apply append (map final-bindings (clause 'subclauses))))


  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the declarations.

  (declarations (clause)
    (apply append (map declarations (clause 'subclauses))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the prologue-form.

  (prologue-form (clause end-tag)
    `(begin ,@(map (lambda (subclause)
                     (prologue-form subclause end-tag))
                   (clause 'subclauses))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the termination-form.

  (termination-form (clause end-tag)
    `(begin ,@(map (lambda (subclause)
                        (termination-form subclause end-tag))
                      (clause 'subclauses))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the body-form.

  (body-form (clause end-tag)
    `(begin ,@(map (lambda (clause)
                        (body-form clause end-tag))
                      (clause 'subclauses))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Step a FOR-AS clause.

  (step-form (clause)
    `(begin ,@(map step-form (clause 'subclauses)))))

(defclass for-as-subclause (var-and-type-spec-mixin)
  ())


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Manage a list of FOR-AS subclause parsers.

(define *for-as-subclause-parsers* '())

(define (add-for-as-subclause-parser parser)
  (push parser *for-as-subclause-parsers*))

;;; A parser that tries every parser in *FOR-AS-SUBCLAUSE-PARSERS* until one
;;; succeeds.

(define (for-as-subclause-parser tokens)
  (let loop ((parsers *for-as-subclause-parsers*))
    (if (null? parsers)
      (list #f #f tokens)
      (pidgin-destructuring-bind (success result rest)
        ((car parsers) tokens)
        (if success
          (list #t result rest)
          (loop (cdr parsers)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parse a FOR-AS clause.

(define-parser for-as-clause-parser
  (consecutive (lambda (for subclause more-subclauses)
                 (make-instance 'for-as-clause
                   :subclauses (cons subclause more-subclauses)))
               (alternative (keyword-parser 'for)
                            (keyword-parser 'as))
               for-as-subclause-parser
               (repeat* list
                        (consecutive (lambda (and subclause)
                                       subclause)
                                     (keyword-parser 'and)
                                     for-as-subclause-parser))))

(add-clause-parser for-as-clause-parser)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Clause FOR-AS-ARITHMETIC.

(defclass for-as-arithmetic (for-as-subclause var-and-type-spec-mixin)
  (;; The order in which the forms are given.  This is a list of three
   ;; elements FROM, TO, and BY in the order that they were given in
   ;; the clause.
   order
   ;; The form that was given after one of the LOOP keywords FROM,
   ;; UPFROM, or DOWNFROM, or 0 if none of these LOOP keywords was
   ;; given.
   (start-form 0)
   (start-var (gensym))
   ;; The form that was after one of the LOOP keywords TO, UPTO,
   ;; DOWNTO, BELOW, or ABOVE, or NIL if none of these LOOP keywords
   ;; was given.
   (end-form '())
   (end-var (gensym))
   ;; The form that was after the LOOP keyword BY, or 0 if this
   ;; keyword was not given.
   (by-form 1)
   (by-var (gensym))
   ;; If termination is TO, UPTO, or DOWNTO, then this slot contains
   ;; the symbol <=.  If termination is ABOVE or BELOW, then this slot
   ;; contains the symbol <.  If there is TO/UPTO/DOWNTO/ABOVE/BELOW,
   ;; then the loop does not terminate because of this clause, and
   ;; then this slot contains NIL.
   (termination-test '())
   ;; This variable is one step ahead of the iteration variable, and
   ;; when the iteration variable is NIL, the value of this variable
   ;; is never assigned to any iteration variable.
   (temp-var (gensym)))

  (bound-variables (subclause)
    (map car
         (extract-variables (subclause 'var-spec) #f)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the bindings.

  (initial-bindings (clause)
    (let ((order (clause 'order)))
      (cond ((equal? order '(from to by))
             `((,(clause 'start-var) ,(clause 'start-form))
               ,@(if (null? (clause 'end-form))
                     '()
                     `((,(clause 'end-var) ,(clause 'end-form))))
               (,(clause 'by-var) ,(clause 'by-form))))
            ((equal? order '(from by to))
             `((,(clause 'start-var) ,(clause 'start-form))
               (,(clause 'by-var) ,(clause 'by-form))
               ,@(if (null? (clause 'end-form))
                     '()
                     `((,(clause 'end-var) ,(clause 'end-form))))))
            ((equal? order '(to from by))
             `(,@(if (null? (clause 'end-form))
                     '()
                     `((,(clause 'end-var) ,(clause 'end-form))))
               (,(clause 'start-var) ,(clause 'start-form))
               (,(clause 'by-var) ,(clause 'by-form))))
            ((equal? order '(to by from))
             `(,@(if (null? (clause 'end-form))
                     '()
                     `((,(clause 'end-var) ,(clause 'end-form))))
               (,(clause 'by-var) ,(clause 'by-form))
               (,(clause 'start-var) ,(clause 'start-form))))
            ((equal? order '(by from to))
             `((,(clause 'by-var) ,(clause 'by-form))
               (,(clause 'start-var) ,(clause 'start-form))
               ,@(if (null? (clause 'end-form))
                     '()
                     `((,(clause 'end-var) ,(clause 'end-form))))))
            ((equal? order '(by to from))
             `((,(clause 'by-var) ,(clause 'by-form))
               ,@(if (null? (clause 'end-form))
                     '()
                     `((,(clause 'end-var) ,(clause 'end-form))))
               (,(clause 'start-var) ,(clause 'start-form)))))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute subclause wrapping.

  (wrap-subclause (subclause inner-form)
    (if (null? (subclause 'var-spec))
        `(let ((,(subclause 'temp-var) ,(subclause 'start-var)))
           ,inner-form)
        `(let ((,(subclause 'temp-var) ,(subclause 'start-var))
               (,(subclause 'var-spec) ,(subclause 'start-var)))
           ;(declare (cl:type ,(type-spec subclause) ,(var-spec subclause)))
           ,inner-form))))

(defclass for-as-arithmetic-up (for-as-arithmetic) ()
  (prologue-form (clause end-tag)
    (if (null? (clause 'termination-test))
        `(set! ,(clause 'temp-var) (+ ,(clause 'temp-var),(clause 'by-var)))
        `(if (,(clause 'termination-test)
              ,(clause 'temp-var)
              ,(clause 'end-var))
             (set! ,(clause 'temp-var) (+ ,(clause 'temp-var) ,(clause 'by-var)))
             (,end-tag))))

  (termination-form (clause end-tag)
    (if (null? (clause 'termination-test))
        '()
        `(unless (,(clause 'termination-test)
                  ,(clause 'temp-var)
                  ,(clause 'end-var))
           (,end-tag))))

  (step-form (clause)
    (if (null? (clause 'var-spec))
        `(set! ,(clause 'temp-var) (+ ,(clause 'temp-var) ,(clause 'by-var)))
        `(begin (set! ,(clause 'var-spec) ,(clause 'temp-var))
                (set! ,(clause 'temp-var) (+ ,(clause 'temp-var) ,(clause 'by-var)))))))

(defclass for-as-arithmetic-down (for-as-arithmetic) ()
  (prologue-form (clause end-tag)
    (if (null? (clause 'termination-test))
        `(set! ,(clause 'temp-var) (- ,(clause 'temp-var) ,(clause 'by-var)))
        `(if (,(clause 'termination-test)
              ,(clause 'end-var)
              ,(clause 'temp-var))
             (set! ,(clause 'temp-var) (- ,(clause 'temp-var) ,(clause 'by-var)))
             (,end-tag))))

  (termination-form (clause end-tag)
    (if (null? (clause 'termination-test))
      '()
       `(unless (,(clause 'termination-test)
                 ,(clause 'end-var)
                 ,(clause 'temp-var))
          (,end-tag))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the step-form.


  (step-form (clause)
    (if (null? (clause 'var-spec))
        `(set! ,(clause 'temp-var) (- ,(clause 'temp-var) ,(clause 'by-var)))
        `(begin (set! ,(clause 'var-spec) ,(clause 'temp-var))
                (set! ,(clause 'temp-var) (- ,(clause 'temp-var) ,(clause 'by-var)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; From a TYPE-SPEC determine a value used for variable
;;; initialization and a type to use in a declaration, and return them
;;; as two values.  The type returned may be different from the
;;; TYPE-SPEC argument because we may not be able to determine a
;;; initialization value that would conform to the TYPE-SPEC, and in
;;; that case, we must modify the type so that it covers the
;;; initialization value that we give.
;;;
;;; Perhaps this code should be moved to the code utilities module.

(define (arithmetic-value-and-type type-spec)
  (cond ((eq? type-spec 'fixnum)
         (list 0 type-spec))
        ((eq? type-spec 'float)
         (list 0.0 type-spec))
        ;; We could add some more here, for instance intervals
        ;; of floats.
        (#t
         (list 0 #f))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser for simple variable.

(define-parser simple-var-parser
  (singleton identity
             (lambda (x)
               (or (null? x)
                   (symbol? x)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers for individual keywords.

(define (project-form keyword form)
  form)

(define-parser from-parser
  (consecutive project-form (keyword-parser 'from) anything-parser))

(define-parser upfrom-parser
  (consecutive project-form (keyword-parser 'upfrom) anything-parser))

(define-parser downfrom-parser
  (consecutive project-form (keyword-parser 'downfrom) anything-parser))

(define-parser to-parser
  (consecutive (lambda (keyword form)
                 (cons '<= form))
               (keyword-parser 'to)
               anything-parser))

(define-parser upto-parser
  (consecutive (lambda (keyword form)
                 (cons '<= form))
               (keyword-parser 'upto)
               anything-parser))

(define-parser below-parser
  (consecutive (lambda (keyword form)
                 (cons '< form))
               (keyword-parser 'below)
               anything-parser))

(define-parser downto-parser
  (consecutive (lambda (keyword form)
                 (cons '<= form))
               (keyword-parser 'downto)
               anything-parser))

(define-parser above-parser
  (consecutive (lambda (keyword form)
                 (cons '< form))
               (keyword-parser 'above)
               anything-parser))

(define-parser by-parser
  (consecutive project-form (keyword-parser 'by) anything-parser))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers for arithmetic up.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers where FROM/UPFROM TO/UPTO/BELOW and BY are all present.
;;; Since they can appear in any order, there are 6 different
;;; variations.

;;; Order is FROM TO BY.
(define-parser arithmetic-up-1-parser
  (consecutive (lambda (var type-spec from to by)
                 (make-instance 'for-as-arithmetic-up
                   :order '(from to by)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               (alternative from-parser upfrom-parser)
               (alternative to-parser upto-parser below-parser)
               by-parser))

;;; Order is FROM BY TO.
(define-parser arithmetic-up-2-parser
  (consecutive (lambda (var type-spec from by to)
                 (make-instance 'for-as-arithmetic-up
                   :order '(from by to)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               (alternative from-parser upfrom-parser)
               by-parser
               (alternative to-parser upto-parser below-parser)))

;;; Order is TO FROM BY.
(define-parser arithmetic-up-3-parser
  (consecutive (lambda (var type-spec to from by)
                 (make-instance 'for-as-arithmetic-up
                   :order '(to from by)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               (alternative to-parser upto-parser below-parser)
               (alternative from-parser upfrom-parser)
               by-parser))

;;; Order is TO BY FROM.
(define-parser arithmetic-up-4-parser
  (consecutive (lambda (var type-spec to by from)
                 (make-instance 'for-as-arithmetic-up
                   :order '(to by from)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               (alternative to-parser upto-parser below-parser)
               by-parser
               (alternative from-parser upfrom-parser)))

;;; Order is BY FROM TO.
(define-parser arithmetic-up-5-parser
  (consecutive (lambda (var type-spec by from to)
                 (make-instance 'for-as-arithmetic-up
                   :order '(by from to)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               by-parser
               (alternative from-parser upfrom-parser)
               (alternative to-parser upto-parser below-parser)))

;;; Order is BY TO FROM.
(define-parser arithmetic-up-6-parser
  (consecutive (lambda (var type-spec by to from)
                 (make-instance 'for-as-arithmetic-up
                   :order '(by to from)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               by-parser
               (alternative to-parser upto-parser below-parser)
               (alternative from-parser upfrom-parser)))

(define-parser three-keyword-up-parser
  (alternative arithmetic-up-1-parser
               arithmetic-up-2-parser
               arithmetic-up-3-parser
               arithmetic-up-4-parser
               arithmetic-up-5-parser
               arithmetic-up-6-parser))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers where only FROM/UPFROM and TO/UPTO/BELOW appear (BY is
;;; omitted).  Since they can appear in any order, there are 2
;;; different variations.

;;; Order is FROM TO.
(define-parser arithmetic-up-7-parser
  (consecutive (lambda (var type-spec from to)
                 (make-instance 'for-as-arithmetic-up
                   :order '(from to by)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               (alternative from-parser upfrom-parser)
               (alternative to-parser upto-parser below-parser)))

;;; Order is TO FROM.
(define-parser arithmetic-up-8-parser
  (consecutive (lambda (var type-spec to from)
                 (make-instance 'for-as-arithmetic-up
                   :order '(to from by)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               (alternative to-parser upto-parser below-parser)
               (alternative from-parser upfrom-parser)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers where only FROM/UPFROM and BY appear (TO/UPTO/BELOW is
;;; omitted).  Since they can appear in any order, there are 2
;;; different variations.

;;; Order is FROM BY.
(define-parser arithmetic-up-9-parser
  (consecutive (lambda (var type-spec from by)
                 (make-instance 'for-as-arithmetic-up
                   :order '(from by to)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :by-form by))
               simple-var-parser
               optional-type-spec-parser
               (alternative from-parser upfrom-parser)
               by-parser))

;;; Order is BY FROM.
(define-parser arithmetic-up-10-parser
  (consecutive (lambda (var type-spec by from)
                 (make-instance 'for-as-arithmetic-up
                   :order '(by from to)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :by-form by))
               simple-var-parser
               optional-type-spec-parser
               by-parser
               (alternative from-parser upfrom-parser)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers where only TO/UPTO/BELOW and BY appear (FROM/UPFROM is
;;; omitted).  Since they can appear in any order, there are 2
;;; different variations.

;;; Order is TO BY.
(define-parser arithmetic-up-11-parser
  (consecutive (lambda (var type-spec to by)
                 (make-instance 'for-as-arithmetic-up
                   :order '(to by from)
                   :var-spec var
                   :type-spec type-spec
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               (alternative to-parser upto-parser below-parser)
               by-parser))

;;; Order is BY TO.
(define-parser arithmetic-up-12-parser
  (consecutive (lambda (var type-spec by to)
                 (make-instance 'for-as-arithmetic-up
                   :order '(by to from)
                   :var-spec var
                   :type-spec type-spec
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               by-parser
               (alternative to-parser upto-parser below-parser)))

(define-parser two-keyword-up-parser
  (alternative arithmetic-up-7-parser
               arithmetic-up-8-parser
               arithmetic-up-9-parser
               arithmetic-up-10-parser
               arithmetic-up-11-parser
               arithmetic-up-12-parser))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser where only FROM/UPFROM appears (TO/UPTO/BELOW and BY are
;;; omitted).

(define-parser arithmetic-up-13-parser
  (consecutive (lambda (var type-spec from)
                 (make-instance 'for-as-arithmetic-up
                   :order '(from to by)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from))
               simple-var-parser
               optional-type-spec-parser
               (alternative from-parser upfrom-parser)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser where only TO/UPTO/BELOW appears (FROM/UPFROM and BY are
;;; omitted).

(define-parser arithmetic-up-14-parser
  (consecutive (lambda (var type-spec to)
                 (make-instance 'for-as-arithmetic-up
                   :order '(to from by)
                   :var-spec var
                   :type-spec type-spec
                   :end-form (cdr to)
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               (alternative to-parser upto-parser below-parser)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser where only BY appears (FROM/UPFROM and TO/UPTO/BELOW are
;;; omitted).

(define-parser arithmetic-up-15-parser
  (consecutive (lambda (var type-spec by)
                 (make-instance 'for-as-arithmetic-up
                   :order '(by to from)
                   :var-spec var
                   :type-spec type-spec
                   :by-form by))
               simple-var-parser
               optional-type-spec-parser
               by-parser))

(define-parser one-keyword-up-parser
  (alternative arithmetic-up-13-parser
               arithmetic-up-14-parser
               arithmetic-up-15-parser))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers for arithmetic down.
;;;
;;; There is no default start value for decremental stepping, so
;;; either FROM or DOWNFROM must always be supplied.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers where FROM/DOWNFROM TO/DOWNTO/ABOVE and BY are all present.
;;;
;;; The combination FROM - TO is not allowed.

;;; FROM/DOWNFROM - DOWNTO/ABOVE - BY
(define-parser arithmetic-down-1-parser
  (consecutive (lambda (var type-spec from to by)
                 (make-instance 'for-as-arithmetic-down
                   :order '(from to by)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               (alternative from-parser downfrom-parser)
               (alternative downto-parser above-parser)
               by-parser))

;;; FROM/DOWNFROM - BY - DOWNTO/ABOVE
(define-parser arithmetic-down-2-parser
  (consecutive (lambda (var type-spec from by to)
                 (make-instance 'for-as-arithmetic-down
                   :order '(from by to)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               (alternative from-parser downfrom-parser)
               by-parser
               (alternative downto-parser above-parser)))

;;; DOWNTO/ABOVE - FROM/DOWNFROM - BY
(define-parser arithmetic-down-3-parser
  (consecutive (lambda (var type-spec to from by)
                 (make-instance 'for-as-arithmetic-down
                   :order '(to from by)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               (alternative downto-parser above-parser)
               (alternative from-parser downfrom-parser)
               by-parser))

;;; DOWNTO/ABOVE - BY - FROM/DOWNFROM
(define-parser arithmetic-down-4-parser
  (consecutive (lambda (var type-spec to by from)
                 (make-instance 'for-as-arithmetic-down
                   :order '(to by from)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               (alternative downto-parser above-parser)
               by-parser
               (alternative from-parser downfrom-parser)))

;;; BY- FROM/DOWNFROM - DOWNTO/ABOVE
(define-parser arithmetic-down-5-parser
  (consecutive (lambda (var type-spec by from to)
                 (make-instance 'for-as-arithmetic-down
                   :order '(by from to)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               by-parser
               (alternative from-parser downfrom-parser)
               (alternative downto-parser above-parser)))

;;; BY- DOWNTO/ABOVE - FROM/DOWNFROM
(define-parser arithmetic-down-6-parser
  (consecutive (lambda (var type-spec by to from)
                 (make-instance 'for-as-arithmetic-down
                   :order '(by to from)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               by-parser
               (alternative downto-parser above-parser)
               (alternative from-parser downfrom-parser)))

;;; DOWNFROM - TO/DOWNTO/ABOVE - BY
(define-parser arithmetic-down-7-parser
  (consecutive (lambda (var type-spec from to by)
                 (make-instance 'for-as-arithmetic-down
                   :order '(from to by)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               downfrom-parser
               (alternative to-parser downto-parser above-parser)
               by-parser))

;;; DOWNFROM - BY - TO/DOWNTO/ABOVE
(define-parser arithmetic-down-8-parser
  (consecutive (lambda (var type-spec from by to)
                 (make-instance 'for-as-arithmetic-down
                   :order '(from by to)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               downfrom-parser
               by-parser
               (alternative to-parser downto-parser above-parser)))

;;; TO/DOWNTO/ABOVE - DOWNFROM - BY
(define-parser arithmetic-down-9-parser
  (consecutive (lambda (var type-spec to from by)
                 (make-instance 'for-as-arithmetic-down
                   :order '(to from by)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               (alternative to-parser downto-parser above-parser)
               downfrom-parser
               by-parser))

;;; TO/DOWNTO/ABOVE - BY - DOWNFROM
(define-parser arithmetic-down-10-parser
  (consecutive (lambda (var type-spec to by from)
                 (make-instance 'for-as-arithmetic-down
                   :order '(to by from)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               (alternative to-parser downto-parser above-parser)
               by-parser
               downfrom-parser))

;;; BY- DOWNFROM - TO/DOWNTO/ABOVE
(define-parser arithmetic-down-11-parser
  (consecutive (lambda (var type-spec by from to)
                 (make-instance 'for-as-arithmetic-down
                   :order '(by from to)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               by-parser
               downfrom-parser
               (alternative to-parser downto-parser above-parser)))

;;; BY- TO/DOWNTO/ABOVE - DOWNFROM
(define-parser arithmetic-down-12-parser
  (consecutive (lambda (var type-spec by to from)
                 (make-instance 'for-as-arithmetic-down
                   :order '(by to from)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :by-form by
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               by-parser
               (alternative to-parser downto-parser above-parser)
               downfrom-parser))

;;; FROM/DOWNFROM - DOWNTO/ABOVE
(define-parser arithmetic-down-13-parser
  (consecutive (lambda (var type-spec from to)
                 (make-instance 'for-as-arithmetic-down
                   :order '(from to by)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               (alternative from-parser downfrom-parser)
               (alternative downto-parser above-parser)))

;;; DOWNFROM - TO/DOWNTO
(define-parser arithmetic-down-14-parser
  (consecutive (lambda (var type-spec from to)
                 (make-instance 'for-as-arithmetic-down
                   :order '(from to by)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :end-form (cdr to)
                   :termination-test (car to)))
               simple-var-parser
               optional-type-spec-parser
               downfrom-parser
               (alternative downto-parser to-parser)))

;;; DOWNFROM - BY
(define-parser arithmetic-down-15-parser
  (consecutive (lambda (var type-spec from by)
                 (make-instance 'for-as-arithmetic-down
                   :order '(from to by)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from
                   :by-form by))
               simple-var-parser
               optional-type-spec-parser
               downfrom-parser
               by-parser))

;;; DOWNFROM
(define-parser arithmetic-down-16-parser
  (consecutive (lambda (var type-spec from)
                 (make-instance 'for-as-arithmetic-down
                   :order '(from to by)
                   :var-spec var
                   :type-spec type-spec
                   :start-form from))
               simple-var-parser
               optional-type-spec-parser
               downfrom-parser))

(define-parser three-keyword-down-parser
  (alternative arithmetic-down-1-parser
               arithmetic-down-2-parser
               arithmetic-down-3-parser
               arithmetic-down-4-parser
               arithmetic-down-5-parser
               arithmetic-down-6-parser
               arithmetic-down-7-parser
               arithmetic-down-8-parser
               arithmetic-down-9-parser
               arithmetic-down-10-parser
               arithmetic-down-11-parser
               arithmetic-down-12-parser
               arithmetic-down-13-parser
               arithmetic-down-14-parser
               arithmetic-down-15-parser
               arithmetic-down-16-parser))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Define a global parser that tries all the arithmetic parsers until
;;; one succeeds.  We define it so that the parsers that require the
;;; largest number of tokens are tested first.  We must do it that
;;; way, because otherwise, a parser requiring a smaller number of
;;; tokens may succeed without having parsed the following tokens.
;;; Those unparsed tokens will then provoke a parse failure when an
;;; attempt is made to parse them as a clause.

(define-parser for-as-arithmetic-parser
  (alternative three-keyword-up-parser
               three-keyword-down-parser
               two-keyword-up-parser
               one-keyword-up-parser))

(add-for-as-subclause-parser for-as-arithmetic-parser)
(defclass for-as-list (for-as-subclause)
  (list-form
   (list-var (gensym))
   by-form
   (by-var (gensym))
   (rest-var (gensym)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the bindings.

  (initial-bindings (clause)
    `((,(clause 'list-var) ,(clause 'list-form))
      ,@(if (simple-by-form? (clause 'by-form))
            '()
            `((,(clause 'by-var) ,(clause 'by-form))))))

  (final-bindings (clause)
    `((,(clause 'rest-var) ,(clause 'list-var))
      ,@(let ((d-var-spec (clause 'var-spec))
              (d-type-spec (clause 'type-spec)))
          (map (compose (rbind list #<undefined>) car) (extract-variables d-var-spec d-type-spec)))))

 (bound-variables (subclause)
   (map car
        (extract-variables (subclause 'var-spec) #f)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the declarations.

  (declarations (clause)
    '()) ;todo
  )

(define (simple-by-form? f)
  (or (symbol? f) (member f (list cdr cddr))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Clause FOR-AS-IN-LIST.

(defclass for-as-in-list (for-as-list) ()
  (prologue-form (clause end-tag)
    `(begin ,(termination-form clause end-tag)
            ,(generate-assignments (clause 'var-spec) `(car ,(clause 'rest-var)))
            (set! ,(clause 'rest-var)
                  (,(if (simple-by-form? (clause 'by-form)) (clause 'by-form) (clause 'by-var)) ,(clause 'rest-var)))))

  (termination-form (clause end-tag)
    `(when (null? ,(clause 'rest-var))
       (,end-tag)))

  (step-form ((clause for-as-in-list))
    `(begin ,(generate-assignments (clause 'var-spec) `(car ,(clause 'rest-var)))
            (set! ,(clause 'rest-var)
                  (,(if (simple-by-form? (clause 'by-form)) (clause 'by-form) (clause 'by-var)) ,(clause 'rest-var))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser for-as-in-list-parser-1
  (consecutive (lambda (var type-spec in list-form by-form)
                 (make-instance 'for-as-in-list
                   :var-spec var
                   :type-spec type-spec
                   :list-form list-form
                   :by-form by-form))
               anything-parser
               optional-type-spec-parser
               (keyword-parser 'in)
               anything-parser
               by-parser))

(define-parser for-as-in-list-parser-2
  (consecutive (lambda (var type-spec in list-form)
                 (make-instance 'for-as-in-list
                   :var-spec var
                   :type-spec type-spec
                   :list-form list-form
                   :by-form cdr))
               anything-parser
               optional-type-spec-parser
               (keyword-parser 'in)
               anything-parser))

;;; Define a parser that tries the longer form first
(define-parser for-as-in-list-parser
  (alternative for-as-in-list-parser-1
               for-as-in-list-parser-2))

(add-for-as-subclause-parser for-as-in-list-parser)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Clause FOR-AS-ON-LIST.

(defclass for-as-on-list (for-as-list) ()
  (prologue-form (clause end-tag)
    `(begin ,(termination-form clause end-tag)
            ,(generate-assignments (clause 'var-spec) (clause 'rest-var))
            (set! ,(clause 'rest-var)
                  (,(if (simple-by-form? (clause 'by-form)) (clause 'by-form) (clause 'by-var)) ,(clause 'rest-var)))))

  (termination-form (clause end-tag)
    `(unless (pair? ,(clause 'rest-var))
       (,end-tag)))

  (step-form (clause)
    `(begin ,(generate-assignments (clause 'var-spec) (clause 'rest-var))
            (set! ,(clause 'rest-var)
                   (,(if (simple-by-form? (clause 'by-form)) (clause 'by-form) (clause 'by-var)) ,(clause 'rest-var))))))

(define-parser for-as-on-list-parser-1
  (consecutive (lambda (var type-spec on list-form by-form)
                 (make-instance 'for-as-on-list
                   :var-spec var
                   :type-spec type-spec
                   :list-form list-form
                   :by-form by-form))
               anything-parser
               optional-type-spec-parser
               (keyword-parser 'on)
               anything-parser
               by-parser))

(define-parser for-as-on-list-parser-2
  (consecutive (lambda (var type-spec on list-form)
                 (make-instance 'for-as-on-list
                   :var-spec var
                   :type-spec type-spec
                   :list-form list-form
                   :by-form cdr))
               anything-parser
               optional-type-spec-parser
               (keyword-parser 'on)
               anything-parser))

;;; Define a parser that tries the longer form first
(define-parser for-as-on-list-parser
  (alternative for-as-on-list-parser-1
               for-as-on-list-parser-2))

(add-for-as-subclause-parser for-as-on-list-parser)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Clause FOR-AS-EQUALS-THEN.

(defclass for-as-equals-then (for-as-subclause)
  (initial-form subsequent-form)

 (bound-variables ((subclause for-as-equals-then))
   (map car (extract-variables (subclause 'var-spec) #f)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the bindings.

  (initial-bindings (clause)
    (let ((d-var-spec (clause 'var-spec))
          (d-type-spec (clause 'type-spec)))
      (map (compose (rbind list #<undefined>) car) (extract-variables d-var-spec d-type-spec))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the declarations.

  (declarations (clause)
    '()) ;todo...?

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the prologue-form.

  (prologue-form (clause end-tag)
    (pidgin-destructuring-bind (temp-tree dictionary)
        (fresh-variables (clause 'var-spec))
      `(let* ,(destructure-variables temp-tree (clause 'initial-form))
         ,@(map (lambda (ot) `(set! ,(car ot) ,(cdr ot))) dictionary))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute the step-form.

  (step-form (clause)
    (pidgin-destructuring-bind (temp-tree dictionary)
        (fresh-variables (clause 'var-spec))
      `(let* ,(destructure-variables temp-tree (clause 'subsequent-form))
         ,@(map (lambda (ot) `(set! ,(car ot) ,(cdr ot))) dictionary)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser for-as-equals-then-parser-1
  (consecutive (lambda (var-spec type-spec = form1 then form2)
                 (make-instance 'for-as-equals-then
                   :var-spec var-spec
                   :type-spec type-spec
                   :initial-form form1
                   :subsequent-form form2))
               ;; Accept anything for now.  Analyze later.
               anything-parser
               optional-type-spec-parser
               (keyword-parser '=)
               anything-parser
               (keyword-parser 'then)
               anything-parser))

(define-parser for-as-equals-then-parser-2
  (consecutive (lambda (var-spec type-spec = form1)
                 (make-instance 'for-as-equals-then
                   :var-spec var-spec
                   :type-spec type-spec
                   :initial-form form1
                   :subsequent-form form1))
               ;; Accept anything for now.  Analyze later.
               anything-parser
               optional-type-spec-parser
               (keyword-parser '=)
               anything-parser))

;;; Make sure parser 1 is tried first.  For that, it must be added
;;; last.
(add-for-as-subclause-parser for-as-equals-then-parser-2)
(add-for-as-subclause-parser for-as-equals-then-parser-1)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Clause FOR-AS-ACROSS

(defclass for-as-across (for-as-subclause var-and-type-spec-mixin)
  (;; This slot contains a copy of the tree contained in the VAR-SPEC
   ;; slot except that the non-NIL leaves have been replaced by
   ;; GENSYMs.
   temp-vars
   ;; This slot contains a list of pairs.  Each pair is a CONS cell
   ;; where the CAR is a variable in VAR-SPEC and the CDR is the
   ;; corresponding variable in TEMP-VARS.
   dictionary
   iterator-form
   (form-var (gensym))
   (next-item-var (gensym)))

  ;;; The FOR-AS-ACROSS clasue binds all the variables in the VAR-SPEC
  ;;; of the clause, so this method should return a list of all those
  ;;; variables.
  (bound-variables (clause)
    (map car
         (extract-variables (clause 'var-spec) #f)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute bindings.

  (initial-bindings (clause)
    `((,(clause 'form-var) (make-iterator ,(clause 'iterator-form)
                                          ; if we're not destructuring, user expects unique pairs
                                          ; but if we are, user never gets at the pairs
                                          ; so we're free to reuse
                                          ,@(if (pair? (clause 'var-spec))
                                              '((cons '() '()))
                                              '())))
      (,(clause 'next-item-var) #<undefined>)))

  (final-bindings (clause)
    `(,@(map (compose (rbind list #<undefined>) car) (clause 'dictionary))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute declarations.

  (declarations (clause)
    '()) ;todo

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute prologue-form.

  (prologue-form (clause end-tag)
    `(begin (set! ,(clause 'next-item-var) (,(clause 'form-var)))
            ,(termination-form clause end-tag)
            ,(generate-assignments (clause 'var-spec)
                                   (clause 'next-item-var))
            (set! ,(clause 'next-item-var) (,(clause 'form-var)))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute termination-form

  (termination-form (clause end-tag)
    `(when (iterator-at-end? ,(clause 'form-var))
       (,end-tag)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Compute step-form.

  (step-form (clause)
    `(begin ,(generate-assignments (clause 'var-spec)
                                   (clause 'next-item-var))
            (set! ,(clause 'next-item-var) (,(clause 'form-var))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser

(define-parser for-as-across-parser
  (consecutive (lambda (var type-spec across iterator-form)
                 (pidgin-destructuring-bind (temp-vars dictionary)
                     (fresh-variables var)
                   (make-instance 'for-as-across
                     :var-spec var
                     :type-spec type-spec
                     :temp-vars temp-vars
                     :dictionary dictionary
                     :iterator-form iterator-form)))
               anything-parser
               optional-type-spec-parser
               (keyword-parser 'across)
               anything-parser))

(add-for-as-subclause-parser for-as-across-parser)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Syntactic and semantic analysis

;;; Check that if there is a name-clause, the last one is in position
;;; zero.
(define (check-name-clause-position clauses)
  (let ((name-clause-position
          (position-if-from-end (rbind type? 'name-clause) clauses)))
    (when (and name-clause-position (positive? name-clause-position))
      (error 'name-clause-not-first))))

;;; Check that there is not a variable-clause following a main clause.
;;; Recall that we diverge from the BNF grammar in the HyperSpec so
;;; that INITIALLY and FINALLY are neither main clauses nor variable
;;; clauses.
(define (check-order-variable-clause-main-clause clauses)
  (let ((last-variable-clause-position
          (position-if-from-end (rbind type? 'variable-clause) clauses))
        (first-main-clause-position
          (position-if (rbind type? 'main-clause) clauses)))
    (when (and last-variable-clause-position
               first-main-clause-position
               (> last-variable-clause-position first-main-clause-position))
      (error 'invalid-clause-order))))

(define (verify-clause-order clauses)
  (check-name-clause-position clauses)
  (check-order-variable-clause-main-clause clauses))

(define (check-variable-uniqueness clauses)
  (let* ((variables (apply append (map bound-variables clauses)))
         (unique-variables (remove-duplicates variables eq?)))
    (unless (= (length variables)
               (length unique-variables))
      (map (lambda (var) (when (> (count var variables eq?) 1)
                           (error 'multiple-variable-occurrences
                                  :bound-variable var)))
           unique-variables))))

;;; Check that for a given accumulation variable, there is only one
;;; category.  Recall that the accumlation categores are represented
;;; by the symbols LIST, COUNT/SUM, and MAX/MIN.
(define (check-accumulation-categories clauses)
  (let* ((descriptors (apply append (map accumulation-variables clauses)))
         (equal-fun (lambda (d1 d2)
                      (and (eq? (car d1) (car d2))
                           (eq? (cadr d1) (cadr d2)))))
         (unique (remove-duplicates descriptors equal-fun)))
    (for-each-on (lambda (remaining)
                   (let ((entry (member (caar remaining)
                                (cdr remaining)
                                (hook eq? car))))
                     (when entry
                       (error "the accumulation variable ~s is used both for ~s accumulation and ~s accumulation."
                              (caar remaining)
                              (cdar remaining)
                              (cdar entry)))))
                 unique)))

;;; Check that there is no overlap between the bound variables and the
;;; accumulation variables.
(define (check-no-variable-overlap clauses)
  (let ((bound-variables
          (apply append (map bound-variables clauses)))
        (accumulation-variables
          (map car
               (apply append
                      (map accumulation-variables clauses)))))
    (let ((intersection
            (intersection bound-variables accumulation-variables
                          eq?)))
      (unless (null? intersection)
        (error "The variable ~s is used both as an iteration variable and as an accumulation variable."
               (car intersection))))))

;;; FIXME: Add more analyses.
(define (analyze-clauses clauses)
  (verify-clause-order clauses)
  (check-variable-uniqueness clauses)
  (check-accumulation-categories clauses)
  (check-no-variable-overlap clauses))
;;; This function is called in a SUM clause in order to sum the
;;; accumulated value with the new one.
(define (sum x . y)
  (for-each (lambda (y)
              (unless (number? y)
                (error 'sum-argument-must-be-number
                       :datum y
                       :expected-type 'number))
              (set! x (+ x y)) y)
            y)
  x)

;;; This function is called in MAX and MIN clauses to ensure that new values
;;; are real.
(define (ensure-real x what)
  (unless (real? x)
    (error what
           :datum x
           :expected-type 'real))
  x)


;;; This function is called in a MAX clause in order to compute the
;;; max of the accumulated value and the new one.
(define (maximize x . y)
  (for-each (lambda (y)
              (set! x (max x (ensure-real y 'max-argument-must-be-real))))
            y)
  x)

;;; This function is called in a MIN clause in order to compute the
;;; min of the accumulated value and the new one.
(define (minimize x . y)
  (for-each (lambda (y)
              (set! x (min x (ensure-real y 'min-argument-must-be-real))))
            y)
  x)

;;; This function is called during restructuring to compute the CAR of
;;; some value.  If that value turns out not to be a LIST, then an
;;; error is signaled.
(define (list-car x)
  (if (pair? x)
      (car x)
      (error 'value-must-be-list
             :datum x
             :expected-type 'list)))

;;; This function is called during restructuring to compute the CDR of
;;; some value.  If that value turns out not to be a LIST, then an
;;; error is signaled.
(define (list-cdr x)
  (if (pair? x)
      (cdr x)
      (error 'value-must-be-list
             :datum x
             :expected-type 'list)))

(define (last x)
  (if (not (pair? (cdr x)))
    x
    (last (cdr x))))

(define (copy-list x)
  (if (not (pair? x)) x (cons (car x) (copy-list (cdr x)))))
(macro forms (expand-body forms))))

(define-expansion (defexpansion name pspec . body) `(define-expansion* (,name , at pspec) , at body))
(defexpansion lambda (pspec :rest body) (if (and (pair? body) (string? (car body)))
                                          `(let ((+documentation+ ,(car body))) (lambda* ,pspec ,@(cdr body)))
                                          `(lambda* ,pspec , at body)))
(defexpansion macro (pspec :rest body) (if (and (pair? body) (string? (car body)))
                                          `(let ((+documentation+ ,(car body))) (macro* ,pspec ,@(cdr body)))
                                          `(macro* ,pspec , at body)))
(defexpansion defun (name pspec :rest body) (if (and (pair? body) (string? (car body)))
                                              `(define ,name (let ((+documentation+ ,(car body))) (lambda (, at pspec) ,@(cdr body))))
                                              `(define* (,name , at pspec) , at body)))
(defexpansion defmacro (name pspec :rest body) (if (and (pair? body) (string? (car body)))
                                                 `(define ,name (let ((+documentation+ ,(car body))) (macro (, at pspec) ,@(cdr body))))
                                                 `(define-macro* (,name , at pspec) , at body)))
(defexpansion incf (x (inc 1))
              `(set! ,x (+ ,x ,inc)))
(defexpansion decf (x (dec 1))
              `(set! ,x (- ,x ,dec)))

(defexpansion block (:rest body)
              `(call-with-exit (lambda (return) , at body)))
(defexpansion assert (c) `(unless ,c (error 'assertion-failure "unhandled assertion ~a" ',c)))

(defexpansion push (v sym)
              (assert (symbol? sym))
              `(begin
                 (set! ,sym (cons ,v ,sym))
                 ,sym))

(defexpansion add-reader (character :rest body)
              (let ((str (gensym)))
                `(set! *#readers*
                   (cons (cons ,character (lambda (,str)
                                            (decf (port-position (current-input-port)) (- (length ,str) 1))
                                            , at body)) *#readers*))))

(defexpansion prog1 (form1 :rest forms)
              (let ((sym (gensym)))
                `(let ((,sym ,form1))
                   , at forms
                   ,sym)))

; unescaped strings, with syntax like
; #q/foo/
; #q|bar\|
; #q{these {do} nest}
(add-reader #\q
            (let* ((openers "[{(<")
                   (closers "]})>")
                   (open-delimiter (read-char))
                   (close-delimiter (let ((i (char-position open-delimiter openers)))
                                      (if i (closers i) open-delimiter)))
                   (depth 1))
              (apply string (loop for c = (peek-char)
                                  do (apply case c
                                            `(((#<eof>) (error 'string-read-error "unexpected end of file in delimited string"))
                                              ((,close-delimiter) (decf depth))
                                              ((,open-delimiter) (incf depth))))
                                  while (> depth 0)
                                  collect (read-char)
                                  finally (read-char)))))
; #/foo/ too, just for nice
; maybe this should be a regex literal?

(add-reader #\L `(lambda ($) ,(read)))
; #'x ?? (char->integer #\x), but with utf8 decoding
(add-reader #\'
            (letrec ((read-continuation-bytes (macro (res n)
                                                     (let ((s (gensym)))
                                                       `(let ((,s (read-byte)))
                                                          (unless (<= ,s #b10111111) (error 'utf8-error "bad continuation byte"))
                                                          (set! ,res (+ (ash ,res 6) (logand ,s #b01111111)))
                                                          ,(if (> n 1)
                                                             `(read-continuation-bytes ,res ,(- n 1))
                                                             res))))))
              (let ((b0 (read-byte)))
                (cond
                  ((<= b0 #b01111111) b0)
                  ((<= b0 #b11011111) (set! b0 (logand b0 #b00111111))
                                      (read-continuation-bytes b0 1))
                  ((<= b0 #b11101111) (set! b0 (logand b0 #b00011111))
                                      (read-continuation-bytes b0 2))
                  ((<= b0 #b11110111) (set! b0 (logand b0 #b00001111))
                                      (read-continuation-bytes b0 3))
                  (#t (error 'utf8-error "bad initial byte"))))))

(defun utf8-encode (c)
  (cond
    ((< c 128) (string (integer->char c)))
    ((< c 2048) (let ((b1 (logand c #b111111))
                      (b0 (ash c -6)))
                  (string (integer->char (logior b0 #b11000000))
                          (integer->char (logior b1 #b10000000)))))
    ((< c 65536) (let ((b2 (logand c #b111111))
                       (b1 (logand (ash c -6) #b111111))
                       (b0 (ash c -12)))
                   (string (integer->char (logior b0 #b11100000))
                           (integer->char (logior b1 #b10000000))
                           (integer->char (logior b2 #b10000000)))))
    ((< c 2097152) (let ((b3 (logand c #b111111))
                         (b2 (logand (ash c -6) #b111111))
                         (b1 (logand (ash c -12) #b111111))
                         (b0 (ash c -18)))
                     (string (integer->char (logior b0 #b11110000))
                             (integer->char (logior b1 #b10000000))
                             (integer->char (logior b2 #b10000000))
                             (integer->char (logior b3 #b10000000)))))
    (#t (error 'utf8-error "codepoint out of range (must be <2??)"))))

(defexpansion times (spec :rest body)
              (let ((m (gensym))
                    (r (gensym))
                    (rt (gensym))
                    (i (if (pair? spec) (car spec) (gensym)))
                    (n (if (pair? spec) (cadr spec) spec)))
                `(let* ((,r '(#<unspecified))
                        (,rt ,r))
                   (do ((,m ,n)
                        (,i 0 (+ 1 ,i)))
                     ((>= ,i ,m) (cdr ,r))
                     (set! (cdr ,rt) (cons (begin , at body) ()))
                     (set! ,rt (cdr ,rt))))))
(defmacro assert (x)
  `(unless ,x
     (error 'assertion-failure ,(format #f "assertion ~a failed" x))))

(let ((unitab '((#'a 97 "a")
                (#'? 225 "?")
                (#'? 9053 "?")
                (#'? 65551 "?"))))
  (map (lambda (x)
         (assert (= (car x) (cadr x)))
         (assert (string=? (utf8-encode (car x)) (caddr x))))
       unitab))

(assert (equal? '(#q//) '("")))

From bil at ccrma.Stanford.EDU  Wed Jul 21 05:33:43 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Wed, 21 Jul 2021 05:33:43 -0700
Subject: [CM] =?utf-8?q?s7=5Fstring_v=2E_s7=5Fobject=5Fto=5Fc=5Fstring?=
In-Reply-To: <CAO40Min-A21eyJM31jVTJa-wKy8WXC2+R0_cqi8akydTA4++7A@mail.gmail.com>
References: <CAO40Min-A21eyJM31jVTJa-wKy8WXC2+R0_cqi8akydTA4++7A@mail.gmail.com>
Message-ID: <8f5858d12dd63e0fbdfea86834993372@ccrma.stanford.edu>

No it is not a bug.  s7_string returns the bytes of the
scheme string (which is not a C string), somewhat like
display, whereas s7_object_to_c_string returns a human-
readable representation of a scheme object, somewhat like
write:

<1> (format #f "~A" "asdf")  ; display
"asdf"
<2> (format #f "~S" "asdf")  ; write
"\"asdf\""



From bil at ccrma.Stanford.EDU  Wed Jul 21 05:47:36 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Wed, 21 Jul 2021 05:47:36 -0700
Subject: [CM] s7 GC bug
In-Reply-To: <e498ad4a-4adb-4a66-ea1f-28191ef4fd46@elronnd.net>
References: <e498ad4a-4adb-4a66-ea1f-28191ef4fd46@elronnd.net>
Message-ID: <95f582d96b28d358a32e82acb3ab79a4@ccrma.stanford.edu>

I haven't had time yet to look at that problem in detail,
but just to clear up one point: (gc #f) turns off the GC,
so the heap can't expand, so if more space is needed,
everything goes to hell.  Also, you can use
*rootlet-redefinition-hook* to see if globals are
being redefined.  I added these lines to glob.scm"

(set! (*s7* 'heap-size) (* 20 1024000)) ; start with a  huge heap
(set! (hook-functions *rootlet-redefinition-hook*)
       (list (lambda (hook)
               (format *stderr* "redefining ~A ~A~%"
                       (hook 'name) (hook 'value)))))

and glob ran to completion with these warnings (among others):

redefining lambda #<expansion* (pspec :rest body)>
redefining macro #<expansion* (pspec :rest body)>

I think it is lambda that is actually triggering the
unbound symbol error and the free-cell error.




From bil at ccrma.Stanford.EDU  Wed Jul 21 13:24:30 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Wed, 21 Jul 2021 13:24:30 -0700
Subject: [CM] s7 GC bug
In-Reply-To: <e498ad4a-4adb-4a66-ea1f-28191ef4fd46@elronnd.net>
References: <e498ad4a-4adb-4a66-ea1f-28191ef4fd46@elronnd.net>
Message-ID: <9d0bdfadc523afd9acee8395819a9bf0@ccrma.stanford.edu>

Thanks very much for the GC bug.  I think I have fixed it,
but it needs a bunch of testing.  (lambda's new value wan't
being GC marked; it took me a couple hours to figure out why).



From bchristensen-lists at outlook.com  Wed Jul 21 13:31:48 2021
From: bchristensen-lists at outlook.com (Brad Christensen)
Date: Wed, 21 Jul 2021 20:31:48 +0000
Subject: [CM] autoload compiling when shared libs are in *load-path*
Message-ID: <SJ0PR02MB72139AAF0D2F144675599A91B8E39@SJ0PR02MB7213.namprd02.prod.outlook.com>

Greetings,

Although I've added to my compiled repl's `*load-path*` (via `S7_LOAD_PATH` at compile time), and pre-compiled the various `lib*_s7.so` shared libraries to be accessible via that path, an autoload of, for instance *libm* seems to recompile the shared library unless it is found in the current directory:

```
$ s7i
s7: 22-Jul-2021
<1> *load-path*
("/my/path/to/s7" ".")
<2> ls /my/path/to/s7
. . . libm_s7.c   libm_s7.so   libm.scm . . .
<3> (provided? 'libm.scm)
#f
<4> *libm*
writing libm_s7.c
loading libm_s7.so
(inlet . . .)
<5> 
```
Is this a bug or am I missing something? Perhaps it is something peculiar with my setup.

Thanks, Brad


From bil at ccrma.Stanford.EDU  Wed Jul 21 14:14:29 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Wed, 21 Jul 2021 14:14:29 -0700
Subject: [CM] autoload compiling when shared libs are in *load-path*
In-Reply-To: <SJ0PR02MB72139AAF0D2F144675599A91B8E39@SJ0PR02MB7213.namprd02.prod.outlook.com>
References: <SJ0PR02MB72139AAF0D2F144675599A91B8E39@SJ0PR02MB7213.namprd02.prod.outlook.com>
Message-ID: <adf97e247dfaeb2bdd6f3b270938e2f2@ccrma.stanford.edu>

repl.scm adds "libm.scm" as the autoload info for *libm*.
This could instead be a function that looks for libm_s7.so
in the load-path, checks its write date against the
libm_s7.c in that directory, and loads it if up-to-date.
If none found, it loads "libm.scm".  I'd call it a
"lack of enhancement" not a "bug" (this joke goes all
the way back to Apple in the late '70's when yours
truly was at Apple, typing on an Apple II in a temporary shed
on a parking lot in Cupertino.  The inventory program
I was associated with took more than a month to finish
its monthly report).



From iainduncanlists at gmail.com  Wed Jul 21 17:08:31 2021
From: iainduncanlists at gmail.com (Iain Duncan)
Date: Wed, 21 Jul 2021 17:08:31 -0700
Subject: [CM] autoload compiling when shared libs are in *load-path*
In-Reply-To: <adf97e247dfaeb2bdd6f3b270938e2f2@ccrma.stanford.edu>
References: <SJ0PR02MB72139AAF0D2F144675599A91B8E39@SJ0PR02MB7213.namprd02.prod.outlook.com>
	<adf97e247dfaeb2bdd6f3b270938e2f2@ccrma.stanford.edu>
Message-ID: <CAN9NcLwOxkNqM1oZnLMiBeOw+cnGJTGfkNMF-SXCjDargH_GrQ@mail.gmail.com>

Haha, "lack of enhancement", I'm adopting that!  :-)

iain

On Wed, Jul 21, 2021 at 2:14 PM <bil at ccrma.stanford.edu> wrote:

> repl.scm adds "libm.scm" as the autoload info for *libm*.
> This could instead be a function that looks for libm_s7.so
> in the load-path, checks its write date against the
> libm_s7.c in that directory, and loads it if up-to-date.
> If none found, it loads "libm.scm".  I'd call it a
> "lack of enhancement" not a "bug" (this joke goes all
> the way back to Apple in the late '70's when yours
> truly was at Apple, typing on an Apple II in a temporary shed
> on a parking lot in Cupertino.  The inventory program
> I was associated with took more than a month to finish
> its monthly report).
>
> _______________________________________________
> Cmdist mailing list
> Cmdist at ccrma.stanford.edu
> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210721/99207e4f/attachment.html>

From bchristensen-lists at outlook.com  Thu Jul 22 15:01:14 2021
From: bchristensen-lists at outlook.com (Brad Christensen)
Date: Thu, 22 Jul 2021 22:01:14 +0000
Subject: [CM] autoload compiling when shared libs are in *load-path*
In-Reply-To: <SJ0PR02MB72139AAF0D2F144675599A91B8E39@SJ0PR02MB7213.namprd02.prod.outlook.com>
References: <SJ0PR02MB72139AAF0D2F144675599A91B8E39@SJ0PR02MB7213.namprd02.prod.outlook.com>
Message-ID: <SJ0PR02MB721388B647B3035E962B56FFB8E49@SJ0PR02MB7213.namprd02.prod.outlook.com>

I realize now that my presumption may have come from the fact that repl seems to treat its search for libc_s7.so (and perhaps libdl_s7.so) differently than, for example libm_s7.so.

When I first compiled the repl I noticed at first run it would always compile and load libc_s7.so, leaving the artifact in whatever directory I ran the repl from. Not wanting to leave multiple copies of the .so around, I pre-compiled libc_s7.so to the repl's location. Because this worked for libc_s7.so, I presumed it would work the same for the other *_s7.so libs.

That said, I have now realized *cload-directory* is a thing, which could help me wrangle these libs. I see nrepl has '.nrepl' to define autoloaded user customization for such a thing. Not so for repl?

Thanks, Brad


From bil at ccrma.Stanford.EDU  Thu Jul 22 15:23:52 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Thu, 22 Jul 2021 15:23:52 -0700
Subject: [CM] autoload compiling when shared libs are in *load-path*
In-Reply-To: <SJ0PR02MB721388B647B3035E962B56FFB8E49@SJ0PR02MB7213.namprd02.prod.outlook.com>
References: <SJ0PR02MB72139AAF0D2F144675599A91B8E39@SJ0PR02MB7213.namprd02.prod.outlook.com>
	<SJ0PR02MB721388B647B3035E962B56FFB8E49@SJ0PR02MB7213.namprd02.prod.outlook.com>
Message-ID: <e5c8196f4583b563df62a114423e15af@ccrma.stanford.edu>

libc_s7.so is special in the repl case because repl
can't run (as a repl) if it can't find it; the other *.so
files are optional.  Ideally the libc dependencies
would be built into repl.c, like they are in nrepl.c.
I'll add the .repl business to repl.scm.



From dev at mobileink.com  Sun Jul 25 15:05:04 2021
From: dev at mobileink.com (Gregg Reynolds)
Date: Sun, 25 Jul 2021 17:05:04 -0500
Subject: [CM] metadata on vectors?
Message-ID: <CAO40Mi=sYYNkXLxXK1T4dswk+FG0qjjswj0AR6vrsS5jttRs7A@mail.gmail.com>

Hi,

A Starlark "string list" looks like this:  ["a", "b", "c"]

I'm converting this into a Scheme vector of c-objects; the custom c-object
lets me keep track of position metadata (line,col), so my parser/emitter
can round-trip, emitting output that exactly matches the input.

The problem is that I need to keep track of the positions for the string
list brackets. Those are nodes in the AST, as are the commas in the list,
but I'm omitting them from the vector, it doesn't make much sense for a
string vector to include punctuation. I can add metadata for the commas to
the custom string nodes, but that leaves the bracket delimiters.

 The easy way to do that would be to add the info as metadata on the Scheme
vector. Is there a way to do that with s7?  I've been looking at the "let"
stuff but I don't see a way to do it.  I see that c-objects have an
"object-let", and (object->let  myvec) returns an inlet, but I don't see
how to elaborate the object-let of a Scheme vector.

(I'm trying to avoid writing custom c-type code for my lists.)

Thanks,

Gregg
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210725/1d077c76/attachment.html>

From bil at ccrma.Stanford.EDU  Mon Jul 26 02:21:04 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Mon, 26 Jul 2021 02:21:04 -0700
Subject: [CM] =?utf-8?q?metadata_on_vectors=3F?=
In-Reply-To: <CAO40Mi=sYYNkXLxXK1T4dswk+FG0qjjswj0AR6vrsS5jttRs7A@mail.gmail.com>
References: <CAO40Mi=sYYNkXLxXK1T4dswk+FG0qjjswj0AR6vrsS5jttRs7A@mail.gmail.com>
Message-ID: <eb8f22ef309b687aee187b456e083ada@ccrma.stanford.edu>

object->let is intended as a low-level portion of a
yet-to-be-written debugger.  Perhaps one simple
solution is to use (cons vector data) and pass
that around instead of the bare vector.  Most
scheme objects in s7 do not have an associated
let built-in.



From chris.actondev at gmail.com  Mon Jul 26 03:15:24 2021
From: chris.actondev at gmail.com (Christos Vagias)
Date: Mon, 26 Jul 2021 12:15:24 +0200
Subject: [CM] metadata on vectors?
In-Reply-To: <eb8f22ef309b687aee187b456e083ada@ccrma.stanford.edu>
References: <CAO40Mi=sYYNkXLxXK1T4dswk+FG0qjjswj0AR6vrsS5jttRs7A@mail.gmail.com>
	<eb8f22ef309b687aee187b456e083ada@ccrma.stanford.edu>
Message-ID: <CAG02pQjoSMB3iahLGCfvJpuhJjfmV2Np2iuE8x4JLjUXjNQy6g@mail.gmail.com>

Hi Gregg,

Since you are using c objects already, I suppose you are also using the
getters, ie (my-vector-element) which would return a scheme string.

You could use a dilamda for the vector, and have a getter like (my-vector)
to get all the elements, (my-vector 0) to get an element and (my vector
'meta) for your meta info.

Another approach would be to openlet the dilamda and instead call (meta
my-vector)

On Mon, Jul 26, 2021, 11:21 AM <bil at ccrma.stanford.edu> wrote:

> object->let is intended as a low-level portion of a
> yet-to-be-written debugger.  Perhaps one simple
> solution is to use (cons vector data) and pass
> that around instead of the bare vector.  Most
> scheme objects in s7 do not have an associated
> let built-in.
>
> _______________________________________________
> Cmdist mailing list
> Cmdist at ccrma.stanford.edu
> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210726/af8c4654/attachment.html>

From iainduncanlists at gmail.com  Mon Jul 26 08:20:10 2021
From: iainduncanlists at gmail.com (Iain Duncan)
Date: Mon, 26 Jul 2021 08:20:10 -0700
Subject: [CM] metadata on vectors?
In-Reply-To: <CAG02pQjoSMB3iahLGCfvJpuhJjfmV2Np2iuE8x4JLjUXjNQy6g@mail.gmail.com>
References: <CAO40Mi=sYYNkXLxXK1T4dswk+FG0qjjswj0AR6vrsS5jttRs7A@mail.gmail.com>
	<eb8f22ef309b687aee187b456e083ada@ccrma.stanford.edu>
	<CAG02pQjoSMB3iahLGCfvJpuhJjfmV2Np2iuE8x4JLjUXjNQy6g@mail.gmail.com>
Message-ID: <CAN9NcLzVWLTqZPkSPvdmQ4UJFxUJFWEN5MXVDk6tSuJob1OtdA@mail.gmail.com>

Bill, I'm not saying it would be good to adopt as I'm no language expert,
but Clojure has an interesting metadata system that might be worth looking
at. I mention it only because I remember you asking last year what things
from Clojure were particularly nice.

iain

On Mon, Jul 26, 2021 at 3:16 AM Christos Vagias <chris.actondev at gmail.com>
wrote:

> Hi Gregg,
>
> Since you are using c objects already, I suppose you are also using the
> getters, ie (my-vector-element) which would return a scheme string.
>
> You could use a dilamda for the vector, and have a getter like (my-vector)
> to get all the elements, (my-vector 0) to get an element and (my vector
> 'meta) for your meta info.
>
> Another approach would be to openlet the dilamda and instead call (meta
> my-vector)
>
> On Mon, Jul 26, 2021, 11:21 AM <bil at ccrma.stanford.edu> wrote:
>
>> object->let is intended as a low-level portion of a
>> yet-to-be-written debugger.  Perhaps one simple
>> solution is to use (cons vector data) and pass
>> that around instead of the bare vector.  Most
>> scheme objects in s7 do not have an associated
>> let built-in.
>>
>> _______________________________________________
>> Cmdist mailing list
>> Cmdist at ccrma.stanford.edu
>> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>>
> _______________________________________________
> Cmdist mailing list
> Cmdist at ccrma.stanford.edu
> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210726/4bb8cc03/attachment.html>

From bil at ccrma.Stanford.EDU  Mon Jul 26 12:17:38 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Mon, 26 Jul 2021 12:17:38 -0700
Subject: [CM] =?utf-8?q?metadata_on_vectors=3F?=
In-Reply-To: <CAN9NcLzVWLTqZPkSPvdmQ4UJFxUJFWEN5MXVDk6tSuJob1OtdA@mail.gmail.com>
References: <CAO40Mi=sYYNkXLxXK1T4dswk+FG0qjjswj0AR6vrsS5jttRs7A@mail.gmail.com>
	<eb8f22ef309b687aee187b456e083ada@ccrma.stanford.edu>
	<CAG02pQjoSMB3iahLGCfvJpuhJjfmV2Np2iuE8x4JLjUXjNQy6g@mail.gmail.com>
	<CAN9NcLzVWLTqZPkSPvdmQ4UJFxUJFWEN5MXVDk6tSuJob1OtdA@mail.gmail.com>
Message-ID: <e5f07963bfecb05ba87dd8db69eb1d35@ccrma.stanford.edu>

Here's one way to do that in scheme:

(require mockery.scm)

(define (meta-vector v data)
   (openlet
    (sublet (*mock-vector* 'mock-vector-class)
      'value v
      'mock-type 'mock-vector?
      'meta-data data)))

(define v (meta-vector #(0 1 2) "hiho"))

(display (v 1))
1

(display (v 'meta-data))
hiho

(display v)
#(0 1 2)

(vector? v)
#t

heh heh -- the last is a lie of course; it's actually
a let trying to masquerade as a vector.  mockery.scm
defines several such "mock data" types.



From dev at mobileink.com  Mon Jul 26 14:51:36 2021
From: dev at mobileink.com (Gregg Reynolds)
Date: Mon, 26 Jul 2021 16:51:36 -0500
Subject: [CM] metadata on vectors?
In-Reply-To: <e5f07963bfecb05ba87dd8db69eb1d35@ccrma.stanford.edu>
References: <CAO40Mi=sYYNkXLxXK1T4dswk+FG0qjjswj0AR6vrsS5jttRs7A@mail.gmail.com>
	<eb8f22ef309b687aee187b456e083ada@ccrma.stanford.edu>
	<CAG02pQjoSMB3iahLGCfvJpuhJjfmV2Np2iuE8x4JLjUXjNQy6g@mail.gmail.com>
	<CAN9NcLzVWLTqZPkSPvdmQ4UJFxUJFWEN5MXVDk6tSuJob1OtdA@mail.gmail.com>
	<e5f07963bfecb05ba87dd8db69eb1d35@ccrma.stanford.edu>
Message-ID: <CAO40Mi=KHRJ4uQns6vFhPxSL0a2bUwDiEM_HmMgekEgypEpSLw@mail.gmail.com>

Cool. Thanks all.

On Mon, Jul 26, 2021 at 2:18 PM <bil at ccrma.stanford.edu> wrote:

> Here's one way to do that in scheme:
>
> (require mockery.scm)
>
> (define (meta-vector v data)
>    (openlet
>     (sublet (*mock-vector* 'mock-vector-class)
>       'value v
>       'mock-type 'mock-vector?
>       'meta-data data)))
>
> (define v (meta-vector #(0 1 2) "hiho"))
>
> (display (v 1))
> 1
>
> (display (v 'meta-data))
> hiho
>
> (display v)
> #(0 1 2)
>
> (vector? v)
> #t
>
> heh heh -- the last is a lie of course; it's actually
> a let trying to masquerade as a vector.  mockery.scm
> defines several such "mock data" types.
>
> _______________________________________________
> Cmdist mailing list
> Cmdist at ccrma.stanford.edu
> https://cm-mail.stanford.edu/mailman/listinfo/cmdist
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210726/1bae28d4/attachment.html>

From wdouglass at carnegierobotics.com  Thu Jul 29 12:41:56 2021
From: wdouglass at carnegierobotics.com (Woody Douglass)
Date: Thu, 29 Jul 2021 19:41:56 +0000
Subject: [CM] Possible s7_load bugfix
Message-ID: <9a50706910da69abfc9d9624d729db86dcd7f0d3.camel@carnegierobotics.com>

Bill et al,

Please see the attached patch. I was loading a large binary library,
that in turn loads a bunch of other large libraries, some of which
binary, some of which scheme. I was getting a bunch of segfaults and
strange behavior

Adding some gc_protect calls seems to have fixed the issue. Does the
patch i've attached make sense?

Thanks,
Woody Douglass
Software Engineer
Carnegie Robotics LLC
-------------- next part --------------
A non-text attachment was scrubbed...
Name: 0001-protect-init-args.patch
Type: text/x-patch
Size: 1159 bytes
Desc: 0001-protect-init-args.patch
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210729/cfa1fde8/attachment.bin>

From bil at ccrma.Stanford.EDU  Thu Jul 29 12:52:29 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Thu, 29 Jul 2021 12:52:29 -0700
Subject: [CM] =?utf-8?q?Possible_s7=5Fload_bugfix?=
In-Reply-To: <9a50706910da69abfc9d9624d729db86dcd7f0d3.camel@carnegierobotics.com>
References: <9a50706910da69abfc9d9624d729db86dcd7f0d3.camel@carnegierobotics.com>
Message-ID: <ff6ca38fdf5a39c40ff8ecbbc992d2da@ccrma.stanford.edu>

Thanks!  Now that I look at that code, I'm surprised
I never hit that problem.  Your changes do make sense,
but we need to unstack the gc protections.  I'll
send you a possible new version later today.



From chris.actondev at gmail.com  Fri Jul 30 07:55:24 2021
From: chris.actondev at gmail.com (Christos Vagias)
Date: Fri, 30 Jul 2021 16:55:24 +0200
Subject: [CM] define* and :rest bug
Message-ID: <CAG02pQiZ_-mR1JAt1fDPo94G-07dO5JVPm7ViPYweN0jghfG=A@mail.gmail.com>

Hi Bil,

I think I've stumbled upon a bug in define*

(define* (foo a b :rest rest (c #f) (d #f))
  (format #f "a=~A b=~A c=~A d=~A rest=~A"
 a b c d rest))

(foo 1 2 3 4)
returns "a=1 b=2 c=4 d=#f rest=(3 4)"

but, in the returned string, c should be #f
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210730/a80a858d/attachment.html>

From chris.actondev at gmail.com  Fri Jul 30 08:10:55 2021
From: chris.actondev at gmail.com (Christos Vagias)
Date: Fri, 30 Jul 2021 17:10:55 +0200
Subject: [CM] define* and :rest bug
In-Reply-To: <CAG02pQiZ_-mR1JAt1fDPo94G-07dO5JVPm7ViPYweN0jghfG=A@mail.gmail.com>
References: <CAG02pQiZ_-mR1JAt1fDPo94G-07dO5JVPm7ViPYweN0jghfG=A@mail.gmail.com>
Message-ID: <CAG02pQgBzwc7=yEbOp9aN0yKS0zDjmNQqq924wm30qR=5HVOFQ@mail.gmail.com>

My apologies!
After reading the docs again that's the expected functionality.
"the rest parameter, if any, takes up an argument slot just like any other
argument"

But still, I think it'd be a neat future to behave like I had assumed.

On Fri, 30 Jul 2021 at 16:55, Christos Vagias <chris.actondev at gmail.com>
wrote:

> Hi Bil,
>
> I think I've stumbled upon a bug in define*
>
> (define* (foo a b :rest rest (c #f) (d #f))
>   (format #f "a=~A b=~A c=~A d=~A rest=~A"
>  a b c d rest))
>
> (foo 1 2 3 4)
> returns "a=1 b=2 c=4 d=#f rest=(3 4)"
>
> but, in the returned string, c should be #f
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210730/f6516758/attachment.html>

From bil at ccrma.Stanford.EDU  Fri Jul 30 08:21:31 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Fri, 30 Jul 2021 08:21:31 -0700
Subject: [CM] define* and :rest bug
In-Reply-To: <CAG02pQgBzwc7=yEbOp9aN0yKS0zDjmNQqq924wm30qR=5HVOFQ@mail.gmail.com>
References: <CAG02pQiZ_-mR1JAt1fDPo94G-07dO5JVPm7ViPYweN0jghfG=A@mail.gmail.com>
	<CAG02pQgBzwc7=yEbOp9aN0yKS0zDjmNQqq924wm30qR=5HVOFQ@mail.gmail.com>
Message-ID: <f05e8ec84c3abafb17ab71a91154bc6b@ccrma.stanford.edu>

I'm not sure I understand the desired functionality.
The arguments after the rest argument should be like
auxiliary arguments in CL (or whatever they are called) --
basically variable declarations?  Ah, I looked it up --
&aux in the CL lambda list -- I never used those!



From dev at mobileink.com  Fri Jul 30 09:51:08 2021
From: dev at mobileink.com (Gregg Reynolds)
Date: Fri, 30 Jul 2021 11:51:08 -0500
Subject: [CM] value of 'define'
Message-ID: <CAO40Mi=2C_V9H=FK+PtGh97Jok7Tk1GM-Vz=yairYY1BB-zJgQ@mail.gmail.com>

It looks like s7 define returns the value defined:

> (define ast (sunlark-parse-build-file "test/BUILD.test"))
... dump of ast ...

Is there any way to turn that off?  I can tell my _to_string function not
to print the ast, but I still want this to print the ast:

> ast

so that's not a good solution.

Thanks,

Gregg
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210730/a73a73d0/attachment.html>

From bil at ccrma.Stanford.EDU  Fri Jul 30 10:06:03 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Fri, 30 Jul 2021 10:06:03 -0700
Subject: [CM] value of 'define'
In-Reply-To: <CAO40Mi=2C_V9H=FK+PtGh97Jok7Tk1GM-Vz=yairYY1BB-zJgQ@mail.gmail.com>
References: <CAO40Mi=2C_V9H=FK+PtGh97Jok7Tk1GM-Vz=yairYY1BB-zJgQ@mail.gmail.com>
Message-ID: <833f57db50bf18b791f30c7c16d9d6b0@ccrma.stanford.edu>

maybe

(define-macro (my-define symbol value)
   `(begin
      (define ,symbol ,value)
      ',symbol))




From chris.actondev at gmail.com  Fri Jul 30 10:29:10 2021
From: chris.actondev at gmail.com (Christos Vagias)
Date: Fri, 30 Jul 2021 19:29:10 +0200
Subject: [CM] define* and :rest bug
In-Reply-To: <f05e8ec84c3abafb17ab71a91154bc6b@ccrma.stanford.edu>
References: <CAG02pQiZ_-mR1JAt1fDPo94G-07dO5JVPm7ViPYweN0jghfG=A@mail.gmail.com>
	<CAG02pQgBzwc7=yEbOp9aN0yKS0zDjmNQqq924wm30qR=5HVOFQ@mail.gmail.com>
	<f05e8ec84c3abafb17ab71a91154bc6b@ccrma.stanford.edu>
Message-ID: <CAG02pQhxCS3basECyQiDsOoes7hM8pRVfF8EirueF8Pv2Ei_nQ@mail.gmail.com>

Another, better, example:
Imagine you want to write something like apply,
but which accepts some optional argument (let's say debug)

(define* (my-apply f :rest args (debug #f))
  (when debug
    (format *stderr* "passed args: ~A\n" args))
  (apply f args))

(my-apply + 1 2 3) ;; debug is 2, not #f

(my-apply + 1 2 3 :debug #t) ;; args are (1 2 3 :debug #t),  debug is 2
;; error: + argument 2, :debug, is a symbol but should be a number

(my-apply :debug #t + 1 2 3 ) ;; error: parameter set twice, debug in
(:debug #t + 1 2 3)

On Fri, 30 Jul 2021 at 17:21, <bil at ccrma.stanford.edu> wrote:

> I'm not sure I understand the desired functionality.
> The arguments after the rest argument should be like
> auxiliary arguments in CL (or whatever they are called) --
> basically variable declarations?  Ah, I looked it up --
> &aux in the CL lambda list -- I never used those!
>
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210730/7a5bb3f6/attachment.html>

From elronnd at elronnd.net  Fri Jul 30 12:10:44 2021
From: elronnd at elronnd.net (Elijah Stone)
Date: Fri, 30 Jul 2021 12:10:44 -0700 (PDT)
Subject: [CM] value of 'define'
In-Reply-To: <CAO40Mi=2C_V9H=FK+PtGh97Jok7Tk1GM-Vz=yairYY1BB-zJgQ@mail.gmail.com>
References: <CAO40Mi=2C_V9H=FK+PtGh97Jok7Tk1GM-Vz=yairYY1BB-zJgQ@mail.gmail.com>
Message-ID: <4c6ccc27-57b5-9535-8ae5-12ec4ebb8d@elronnd.net>

On Fri, 30 Jul 2021, Gregg Reynolds wrote:

> It looks like s7 define returns the value defined:

> Is there any way to turn that off?? I can tell my _to_string function 
> not to print the ast, but I still want this to print the ast:

(define define
   (let ((o-define define))
     (macro (k v)
       `(begin
          (,o-define ,k ,v)
          ',k))))

From bil at ccrma.Stanford.EDU  Fri Jul 30 12:46:41 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Fri, 30 Jul 2021 12:46:41 -0700
Subject: [CM] define* and :rest bug
In-Reply-To: <CAG02pQhxCS3basECyQiDsOoes7hM8pRVfF8EirueF8Pv2Ei_nQ@mail.gmail.com>
References: <CAG02pQiZ_-mR1JAt1fDPo94G-07dO5JVPm7ViPYweN0jghfG=A@mail.gmail.com>
	<CAG02pQgBzwc7=yEbOp9aN0yKS0zDjmNQqq924wm30qR=5HVOFQ@mail.gmail.com>
	<f05e8ec84c3abafb17ab71a91154bc6b@ccrma.stanford.edu>
	<CAG02pQhxCS3basECyQiDsOoes7hM8pRVfF8EirueF8Pv2Ei_nQ@mail.gmail.com>
Message-ID: <ccd5a1cc40b7b06136768208201479af@ccrma.stanford.edu>

But then what would

   (my-apply + 1 2 3 :debug #t 4 5 6)

expect? Perhaps this would be usable:

(define-macro* (my-apply debug :rest rest)
   `(if (not (boolean? ,debug))
        (apply ,debug ',rest)
        (begin
	 (when ,debug
	   (format *stderr* "debugging\n"))
	 (apply ,(car rest) ',(cdr rest)))))





From dev at mobileink.com  Fri Jul 30 12:48:49 2021
From: dev at mobileink.com (Gregg Reynolds)
Date: Fri, 30 Jul 2021 14:48:49 -0500
Subject: [CM] value of 'define'
In-Reply-To: <4c6ccc27-57b5-9535-8ae5-12ec4ebb8d@elronnd.net>
References: <CAO40Mi=2C_V9H=FK+PtGh97Jok7Tk1GM-Vz=yairYY1BB-zJgQ@mail.gmail.com>
	<4c6ccc27-57b5-9535-8ae5-12ec4ebb8d@elronnd.net>
Message-ID: <CAO40MikZFWF9+HNP9Bp5+LQK1VjTiWUYfVi4MaVMpq8zeL2KuA@mail.gmail.com>

On Fri, Jul 30, 2021 at 2:11 PM Elijah Stone <elronnd at elronnd.net> wrote:

> On Fri, 30 Jul 2021, Gregg Reynolds wrote:
>
> > It looks like s7 define returns the value defined:
>
> > Is there any way to turn that off?  I can tell my _to_string function
> > not to print the ast, but I still want this to print the ast:
>
> (define define
>    (let ((o-define define))
>      (macro (k v)
>        `(begin
>           (,o-define ,k ,v)
>           ',k))))


Ha-ha, I forgot that everything in Scheme is negotiable.  Even more so in
s7:

char *def = "(define define "
   "(let ((o-define define)) "
    "(macro (k v) "
       "`(begin "
          "(,o-define ,k ,v) "
    "',k)))) ";

void sunlark_redefine_define(s7_scheme *s7)
{
    s7_pointer path = s7_eval_c_string(s7, def);
}

Thanks!
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210730/78c6fcbb/attachment.html>

From dev at mobileink.com  Fri Jul 30 12:50:57 2021
From: dev at mobileink.com (Gregg Reynolds)
Date: Fri, 30 Jul 2021 14:50:57 -0500
Subject: [CM] value of 'define'
In-Reply-To: <CAO40MikZFWF9+HNP9Bp5+LQK1VjTiWUYfVi4MaVMpq8zeL2KuA@mail.gmail.com>
References: <CAO40Mi=2C_V9H=FK+PtGh97Jok7Tk1GM-Vz=yairYY1BB-zJgQ@mail.gmail.com>
	<4c6ccc27-57b5-9535-8ae5-12ec4ebb8d@elronnd.net>
	<CAO40MikZFWF9+HNP9Bp5+LQK1VjTiWUYfVi4MaVMpq8zeL2KuA@mail.gmail.com>
Message-ID: <CAO40Mi=izaf8LtBBEWo=uAKgH_gqY1_MmvueY9660TA_8UJA6Q@mail.gmail.com>

On Fri, Jul 30, 2021 at 2:48 PM Gregg Reynolds <dev at mobileink.com> wrote:

...

> void sunlark_redefine_define(s7_scheme *s7)
> {
>     s7_pointer path = s7_eval_c_string(s7, def);
> }
>

Make that:

void sunlark_redefine_define(s7_scheme *s7)
{
    s7_eval_c_string(s7, def);
}
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://cm-mail.stanford.edu/pipermail/cmdist/attachments/20210730/bd4ba14f/attachment.html>

From chris.actondev at gmail.com  Fri Jul 30 14:43:22 2021
From: chris.actondev at gmail.com (Christos Vagias)
Date: Fri, 30 Jul 2021 23:43:22 +0200
Subject: [CM] define* and :rest bug
In-Reply-To: <ccd5a1cc40b7b06136768208201479af@ccrma.stanford.edu>
References: <CAG02pQiZ_-mR1JAt1fDPo94G-07dO5JVPm7ViPYweN0jghfG=A@mail.gmail.com>
	<CAG02pQgBzwc7=yEbOp9aN0yKS0zDjmNQqq924wm30qR=5HVOFQ@mail.gmail.com>
	<f05e8ec84c3abafb17ab71a91154bc6b@ccrma.stanford.edu>
	<CAG02pQhxCS3basECyQiDsOoes7hM8pRVfF8EirueF8Pv2Ei_nQ@mail.gmail.com>
	<ccd5a1cc40b7b06136768208201479af@ccrma.stanford.edu>
Message-ID: <CAG02pQg2m=Qtv_wFTLCNaFUAKYFu2VMhWendoW-GdcJXT2zh3Q@mail.gmail.com>

Good point!
Well the :rest that could be before the other arguments got my hopes
up that I could mix named arguments and the rest.
But,

A perhaps possible solution would be to give priority to "rest" when
the lambda* arguments have a default value, like so:
((lambda* (a (b "the-b") . rest) (list 'a a 'b b 'rest rest)) '(0 1
2)) ;; (a 0 b "the-b" rest (1 2))

In any case in my specific usecase instead of relying on :rest, I
named the argument and I'm passing a list. Perhaps that's better and
more clear in the code as well.

I will look into CL and what "rest" and &aux are there. I guess some
old mailing list might have some discussion on the topic.

Thanks Bil!


On Fri, 30 Jul 2021 at 21:46, <bil at ccrma.stanford.edu> wrote:
>
> But then what would
>
>    (my-apply + 1 2 3 :debug #t 4 5 6)
>
> expect? Perhaps this would be usable:
>
> (define-macro* (my-apply debug :rest rest)
>    `(if (not (boolean? ,debug))
>         (apply ,debug ',rest)
>         (begin
>          (when ,debug
>            (format *stderr* "debugging\n"))
>          (apply ,(car rest) ',(cdr rest)))))
>
>
>


From elronnd at elronnd.net  Sat Jul 31 14:39:33 2021
From: elronnd at elronnd.net (Elijah Stone)
Date: Sat, 31 Jul 2021 14:39:33 -0700 (PDT)
Subject: [CM] S7: empty values list
Message-ID: <c2764c15-24b-9ff5-4624-e24bbab55a4a@elronnd.net>

(define f (lambda x x))
(f (values 2 2))                  ; (2 2)
(f (values))                      ; (#<unspecified>)
(apply f (list-values (values)))  ; ()

Why don't the last two expressions have the same result?


From bil at ccrma.Stanford.EDU  Sat Jul 31 15:17:29 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Sat, 31 Jul 2021 15:17:29 -0700
Subject: [CM] S7: empty values list
In-Reply-To: <c2764c15-24b-9ff5-4624-e24bbab55a4a@elronnd.net>
References: <c2764c15-24b-9ff5-4624-e24bbab55a4a@elronnd.net>
Message-ID: <64e0b43948d2aee1c467ff0094484691@ccrma.stanford.edu>

(values) in that context returns #<unspecified> for
historical reasons, and to make code more readable;
otherwise we get stuff like (abs -1 (f)).  list-values
is intended for use with quasiquote -- the special
case of () is explained in s7.html.



From bchristensen-lists at outlook.com  Sat Jul 31 15:52:19 2021
From: bchristensen-lists at outlook.com (Brad Christensen)
Date: Sat, 31 Jul 2021 22:52:19 +0000
Subject: [CM] Sending code to the REPL from Emacs
Message-ID: <SJ0PR02MB721350017C51FE122718D659B8ED9@SJ0PR02MB7213.namprd02.prod.outlook.com>

Any Emacs users out there with working s7 REPL configs?

I quite like the idea of keeping certain code in an org file and sending code to the REPL. However, I can't quite figure out the configuration required for evaluating multi-line sexp, or even multiple sexps in s7's REPL.

My attempts include using cmuscheme standalone and behind various packages (Doom-emacs' eval module (Quickrun), eval-in-repl, org-babel-eval-in-repl), without luck.

Simple single-line / single sexp work, but any sexp split across a line, or consecutive sexp does this:
```
> (define (add1 n)
  (+ 1 n))

missing close paren: (define (add1 n)
> eval-string trailing junk: ")"

> (+ 1 2 3)(- 4 5 6)
eval-string trailing junk: "(- 4 5 6)"
```
This occurs regardless of whether the code was sent to the REPL or typed in directly. Any pointers appreciated!

Thanks, Brad


From bil at ccrma.Stanford.EDU  Sat Jul 31 16:28:39 2021
From: bil at ccrma.Stanford.EDU (bil at ccrma.Stanford.EDU)
Date: Sat, 31 Jul 2021 16:28:39 -0700
Subject: [CM] Sending code to the REPL from Emacs
In-Reply-To: <SJ0PR02MB721350017C51FE122718D659B8ED9@SJ0PR02MB7213.namprd02.prod.outlook.com>
References: <SJ0PR02MB721350017C51FE122718D659B8ED9@SJ0PR02MB7213.namprd02.prod.outlook.com>
Message-ID: <975047b860d5893c76a95e10766119c0@ccrma.stanford.edu>

> eval-string trailing junk: "(- 4 5 6)"

This happens because the string passed to eval-string
should contain just one expression to be evaluated.
If you want more than one, wrap them in (begin ...)
or (list ...) etc.