lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Clean up whitespace 

- Tabs to spaces
- Remove invisible whitespace at ends of lines
- Break or shorten long lines (not for all files)
This commit is contained in:
Lassi Kortela 2019-08-09 17:18:36 +03:00
parent 09c6368668
commit be9b2b364e
32 changed files with 3092 additions and 3075 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
LICENSE
View File

@ -7,20 +7,20 @@ modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice, * Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer. this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice, * Redistributions in binary form must reproduce the above copyright
this list of conditions and the following disclaimer in the documentation notice, this list of conditions and the following disclaimer in the
and/or other materials provided with the distribution. documentation and/or other materials provided with the distribution.
* Neither the author nor the names of any contributors may be used to * Neither the author nor the names of any contributors may be used to
endorse or promote products derived from this software without specific endorse or promote products derived from this software without specific
prior written permission. prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

2
c/equalhash.c
View File

@ -9,7 +9,7 @@
#include "flisp.h" #include "flisp.h"
#include "equalhash.h" #include "equalhash.h"
#include "htable.inc" #include "htable_inc.h"
#define _equal_lispvalue_(x, y) equal_lispvalue((value_t)(x), (value_t)(y)) #define _equal_lispvalue_(x, y) equal_lispvalue((value_t)(x), (value_t)(y))

2
c/equalhash.h
View File

@ -1,7 +1,7 @@
#ifndef EQUALHASH_H #ifndef EQUALHASH_H
#define EQUALHASH_H #define EQUALHASH_H
#include "htableh.inc" #include "htableh_inc.h"
HTPROT(equalhash) HTPROT(equalhash)

74
c/lookup3.c
View File

@ -1,5 +1,5 @@
/* /*
------------------------------------------------------------------------------- ------------------------------------------------------------------------------
lookup3.c, by Bob Jenkins, May 2006, Public Domain. lookup3.c, by Bob Jenkins, May 2006, Public Domain.
These are functions for producing 32-bit hashes for hash table lookup. These are functions for producing 32-bit hashes for hash table lookup.
@ -31,7 +31,7 @@ Why is this so big? I read 12 bytes at a time into 3 4-byte integers,
then mix those integers. This is fast (you can do a lot more thorough then mix those integers. This is fast (you can do a lot more thorough
mixing with 12*3 instructions on 3 integers than you can with 3 instructions mixing with 12*3 instructions on 3 integers than you can with 3 instructions
on 1 byte), but shoehorning those bytes into integers efficiently is messy. on 1 byte), but shoehorning those bytes into integers efficiently is messy.
------------------------------------------------------------------------------- ------------------------------------------------------------------------------
*/ */
//#define SELF_TEST 1 //#define SELF_TEST 1
@ -74,7 +74,7 @@ typedef unsigned short uint16_t;
#define rot(x, k) (((x) << (k)) | ((x) >> (32 - (k)))) #define rot(x, k) (((x) << (k)) | ((x) >> (32 - (k))))
/* /*
------------------------------------------------------------------------------- ------------------------------------------------------------------------------
mix -- mix 3 32-bit values reversibly. mix -- mix 3 32-bit values reversibly.
This is reversible, so any information in (a,b,c) before mix() is This is reversible, so any information in (a,b,c) before mix() is
@ -115,7 +115,7 @@ direction as the goal of parallelism. I did what I could. Rotates
seem to cost as much as shifts on every machine I could lay my hands seem to cost as much as shifts on every machine I could lay my hands
on, and rotates are much kinder to the top and bottom bits, so I used on, and rotates are much kinder to the top and bottom bits, so I used
rotates. rotates.
------------------------------------------------------------------------------- ------------------------------------------------------------------------------
*/ */
#define mix(a, b, c) \ #define mix(a, b, c) \
{ \ { \
@ -140,7 +140,7 @@ rotates.
} }
/* /*
------------------------------------------------------------------------------- ------------------------------------------------------------------------------
final -- final mixing of 3 32-bit values (a,b,c) into c final -- final mixing of 3 32-bit values (a,b,c) into c
Pairs of (a,b,c) values differing in only a few bits will usually Pairs of (a,b,c) values differing in only a few bits will usually
@ -162,7 +162,7 @@ and these came close:
4 8 15 26 3 22 24 4 8 15 26 3 22 24
10 8 15 26 3 22 24 10 8 15 26 3 22 24
11 8 15 26 3 22 24 11 8 15 26 3 22 24
------------------------------------------------------------------------------- ------------------------------------------------------------------------------
*/ */
#define final(a, b, c) \ #define final(a, b, c) \
{ \ { \
@ -183,7 +183,7 @@ and these came close:
} }
/* /*
-------------------------------------------------------------------- ------------------------------------------------------------------------------
This works on all machines. To be useful, it requires This works on all machines. To be useful, it requires
-- that the key be an array of uint32_t's, and -- that the key be an array of uint32_t's, and
-- that the length be the number of uint32_t's in the key -- that the length be the number of uint32_t's in the key
@ -193,7 +193,7 @@ and these came close:
except that the length has to be measured in uint32_ts rather than in except that the length has to be measured in uint32_ts rather than in
bytes. hashlittle() is more complicated than hashword() only because bytes. hashlittle() is more complicated than hashword() only because
hashlittle() has to dance around fitting the key bytes into registers. hashlittle() has to dance around fitting the key bytes into registers.
-------------------------------------------------------------------- ------------------------------------------------------------------------------
*/ */
uint32_t uint32_t
hashword(const uint32_t *k, /* the key, an array of uint32_t values */ hashword(const uint32_t *k, /* the key, an array of uint32_t values */
@ -287,7 +287,7 @@ void hashword2(const uint32_t *k, /* the key, an array of uint32_t values */
#if 0 #if 0
/* /*
------------------------------------------------------------------------------- ------------------------------------------------------------------------------
hashlittle() -- hash a variable-length key into a 32-bit value hashlittle() -- hash a variable-length key into a 32-bit value
k : the key (the unaligned variable-length array of bytes) k : the key (the unaligned variable-length array of bytes)
length : the length of the key, counting by bytes length : the length of the key, counting by bytes
@ -310,23 +310,23 @@ code any way you wish, private, educational, or commercial. It's free.
Use for hash table lookup, or anything where one collision in 2^^32 is Use for hash table lookup, or anything where one collision in 2^^32 is
acceptable. Do NOT use for cryptographic purposes. acceptable. Do NOT use for cryptographic purposes.
------------------------------------------------------------------------------- ------------------------------------------------------------------------------
*/ */
uint32_t hashlittle( const void *key, size_t length, uint32_t initval) uint32_t hashlittle( const void *key, size_t length, uint32_t initval)
{ {
uint32_t a,b,c; /* internal state */ uint32_t a,b,c; /* internal state */
union { const void *ptr; size_t i; } u; /* needed for Mac Powerbook G4 */ union { const void *ptr; size_t i; } u; /* needed for Mac Powerbook G4 */
/* Set up the internal state */ /* Set up the internal state */
a = b = c = 0xdeadbeef + ((uint32_t)length) + initval; a = b = c = 0xdeadbeef + ((uint32_t)length) + initval;
u.ptr = key; u.ptr = key;
if (HASH_LITTLE_ENDIAN && ((u.i & 0x3) == 0)) { if (HASH_LITTLE_ENDIAN && ((u.i & 0x3) == 0)) {
const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */ const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */
const uint8_t *k8; const uint8_t *k8;
/*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ /*----- all but last block: aligned reads and affect 32 bits of (a,b,c) */
while (length > 12) while (length > 12)
{ {
a += k[0]; a += k[0];
@ -337,8 +337,8 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval)
k += 3; k += 3;
} }
/*----------------------------- handle the last (probably partial) block */ /*---------------------------- handle the last (probably partial) block */
/* /*
* "k[2]&0xffffff" actually reads beyond the end of the string, but * "k[2]&0xffffff" actually reads beyond the end of the string, but
* then masks off the part it's not allowed to read. Because the * then masks off the part it's not allowed to read. Because the
* string is aligned, the masked-off tail is in the same word as the * string is aligned, the masked-off tail is in the same word as the
@ -363,7 +363,7 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval)
case 3 : a+=k[0]&0xffffff; break; case 3 : a+=k[0]&0xffffff; break;
case 2 : a+=k[0]&0xffff; break; case 2 : a+=k[0]&0xffff; break;
case 1 : a+=k[0]&0xff; break; case 1 : a+=k[0]&0xff; break;
case 0 : return c; /* zero length strings require no mixing */ case 0 : return c; /* zero length strings require no mixing */
} }
#else /* make valgrind happy */ #else /* make valgrind happy */
@ -389,10 +389,10 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval)
#endif /* !valgrind */ #endif /* !valgrind */
} else if (HASH_LITTLE_ENDIAN && ((u.i & 0x1) == 0)) { } else if (HASH_LITTLE_ENDIAN && ((u.i & 0x1) == 0)) {
const uint16_t *k = (const uint16_t *)key; /* read 16-bit chunks */ const uint16_t *k = (const uint16_t *)key; /* read 16-bit chunks */
const uint8_t *k8; const uint8_t *k8;
/*--------------- all but last block: aligned reads and different mixing */ /*-------------- all but last block: aligned reads and different mixing */
while (length > 12) while (length > 12)
{ {
a += k[0] + (((uint32_t)k[1])<<16); a += k[0] + (((uint32_t)k[1])<<16);
@ -403,7 +403,7 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval)
k += 6; k += 6;
} }
/*----------------------------- handle the last (probably partial) block */ /*---------------------------- handle the last (probably partial) block */
k8 = (const uint8_t *)k; k8 = (const uint8_t *)k;
switch(length) switch(length)
{ {
@ -432,13 +432,13 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval)
break; break;
case 1 : a+=k8[0]; case 1 : a+=k8[0];
break; break;
case 0 : return c; /* zero length requires no mixing */ case 0 : return c; /* zero length requires no mixing */
} }
} else { /* need to read the key one byte at a time */ } else { /* need to read the key one byte at a time */
const uint8_t *k = (const uint8_t *)key; const uint8_t *k = (const uint8_t *)key;
/*--------------- all but the last block: affect some 32 bits of (a,b,c) */ /*-------------- all but the last block: affect some 32 bits of (a,b,c) */
while (length > 12) while (length > 12)
{ {
a += k[0]; a += k[0];
@ -458,8 +458,8 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval)
k += 12; k += 12;
} }
/*-------------------------------- last block: affect all 32 bits of (c) */ /*------------------------------- last block: affect all 32 bits of (c) */
switch(length) /* all the case statements fall through */ switch(length) /* all the case statements fall through */
{ {
case 12: c+=((uint32_t)k[11])<<24; case 12: c+=((uint32_t)k[11])<<24;
case 11: c+=((uint32_t)k[10])<<16; case 11: c+=((uint32_t)k[10])<<16;
@ -767,22 +767,22 @@ uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */
* hashbig(): * hashbig():
* This is the same as hashword() on big-endian machines. It is different * This is the same as hashword() on big-endian machines. It is different
* from hashlittle() on all machines. hashbig() takes advantage of * from hashlittle() on all machines. hashbig() takes advantage of
* big-endian byte ordering. * big-endian byte ordering.
*/ */
uint32_t hashbig( const void *key, size_t length, uint32_t initval) uint32_t hashbig( const void *key, size_t length, uint32_t initval)
{ {
uint32_t a,b,c; uint32_t a,b,c;
union { const void *ptr; size_t i; } u; /* to cast key to (size_t) happily */ union { const void *ptr; size_t i; } u; /* to cast key to size_t happily */
/* Set up the internal state */ /* Set up the internal state */
a = b = c = 0xdeadbeef + ((uint32_t)length) + initval; a = b = c = 0xdeadbeef + ((uint32_t)length) + initval;
u.ptr = key; u.ptr = key;
if (HASH_BIG_ENDIAN && ((u.i & 0x3) == 0)) { if (HASH_BIG_ENDIAN && ((u.i & 0x3) == 0)) {
const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */ const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */
const uint8_t *k8; const uint8_t *k8;
/*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ /*----- all but last block: aligned reads and affect 32 bits of (a,b,c) */
while (length > 12) while (length > 12)
{ {
a += k[0]; a += k[0];
@ -793,8 +793,8 @@ uint32_t hashbig( const void *key, size_t length, uint32_t initval)
k += 3; k += 3;
} }
/*----------------------------- handle the last (probably partial) block */ /*---------------------------- handle the last (probably partial) block */
/* /*
* "k[2]<<8" actually reads beyond the end of the string, but * "k[2]<<8" actually reads beyond the end of the string, but
* then shifts out the part it's not allowed to read. Because the * then shifts out the part it's not allowed to read. Because the
* string is aligned, the illegal read is in the same word as the * string is aligned, the illegal read is in the same word as the
@ -819,13 +819,13 @@ uint32_t hashbig( const void *key, size_t length, uint32_t initval)
case 3 : a+=k[0]&0xffffff00; break; case 3 : a+=k[0]&0xffffff00; break;
case 2 : a+=k[0]&0xffff0000; break; case 2 : a+=k[0]&0xffff0000; break;
case 1 : a+=k[0]&0xff000000; break; case 1 : a+=k[0]&0xff000000; break;
case 0 : return c; /* zero length strings require no mixing */ case 0 : return c; /* zero length strings require no mixing */
} }
#else /* make valgrind happy */ #else /* make valgrind happy */
k8 = (const uint8_t *)k; k8 = (const uint8_t *)k;
switch(length) /* all the case statements fall through */ switch(length) /* all the case statements fall through */
{ {
case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; case 12: c+=k[2]; b+=k[1]; a+=k[0]; break;
case 11: c+=((uint32_t)k8[10])<<8; /* fall through */ case 11: c+=((uint32_t)k8[10])<<8; /* fall through */
@ -844,10 +844,10 @@ uint32_t hashbig( const void *key, size_t length, uint32_t initval)
#endif /* !VALGRIND */ #endif /* !VALGRIND */
} else { /* need to read the key one byte at a time */ } else { /* need to read the key one byte at a time */
const uint8_t *k = (const uint8_t *)key; const uint8_t *k = (const uint8_t *)key;
/*--------------- all but the last block: affect some 32 bits of (a,b,c) */ /*-------------- all but the last block: affect some 32 bits of (a,b,c) */
while (length > 12) while (length > 12)
{ {
a += ((uint32_t)k[0])<<24; a += ((uint32_t)k[0])<<24;
@ -867,8 +867,8 @@ uint32_t hashbig( const void *key, size_t length, uint32_t initval)
k += 12; k += 12;
} }
/*-------------------------------- last block: affect all 32 bits of (c) */ /*------------------------------- last block: affect all 32 bits of (c) */
switch(length) /* all the case statements fall through */ switch(length) /* all the case statements fall through */
{ {
case 12: c+=k[11]; case 12: c+=k[11];
case 11: c+=((uint32_t)k[10])<<8; case 11: c+=((uint32_t)k[10])<<8;

16
c/mt19937ar.c
View File

@ -154,29 +154,29 @@ long genrand_int31(void)
/* generates a random number on [0,1]-real-interval */ /* generates a random number on [0,1]-real-interval */
double genrand_real1(void) double genrand_real1(void)
{ {
return genrand_int32()*(1.0/4294967295.0); return genrand_int32()*(1.0/4294967295.0);
/* divided by 2^32-1 */ /* divided by 2^32-1 */
} }
/* generates a random number on [0,1)-real-interval */ /* generates a random number on [0,1)-real-interval */
double genrand_real2(void) double genrand_real2(void)
{ {
return genrand_int32()*(1.0/4294967296.0); return genrand_int32()*(1.0/4294967296.0);
/* divided by 2^32 */ /* divided by 2^32 */
} }
/* generates a random number on (0,1)-real-interval */ /* generates a random number on (0,1)-real-interval */
double genrand_real3(void) double genrand_real3(void)
{ {
return (((double)genrand_int32()) + 0.5)*(1.0/4294967296.0); return (((double)genrand_int32()) + 0.5)*(1.0/4294967296.0);
/* divided by 2^32 */ /* divided by 2^32 */
} }
/* generates a random number on [0,1) with 53-bit resolution*/ /* generates a random number on [0,1) with 53-bit resolution*/
double genrand_res53(void) double genrand_res53(void)
{ {
uint32_t a=genrand_int32()>>5, b=genrand_int32()>>6; uint32_t a=genrand_int32()>>5, b=genrand_int32()>>6;
return(a*67108864.0+b)*(1.0/9007199254740992.0); return(a*67108864.0+b)*(1.0/9007199254740992.0);
} }
#endif #endif
/* These real versions are due to Isaku Wada, 2002/01/09 added */ /* These real versions are due to Isaku Wada, 2002/01/09 added */

12
c/utils.h
View File

@ -47,13 +47,13 @@ STATIC_INLINE u_int16_t ByteSwap16(u_int16_t x)
STATIC_INLINE u_int32_t ByteSwap32(u_int32_t x) STATIC_INLINE u_int32_t ByteSwap32(u_int32_t x)
{ {
#if __CPU__ > 386 #if __CPU__ > 386
__asm("bswap %0" __asm("bswap %0"
: "=r"(x) : "=r"(x)
: :
#else #else
__asm("xchgb %b0,%h0\n" __asm("xchgb %b0,%h0\n"
" rorl $16,%0\n" " rorl $16,%0\n"
" xchgb %b0,%h0" " xchgb %b0,%h0"
: LEGACY_REGS(x) : LEGACY_REGS(x)
: :
#endif #endif
@ -66,14 +66,14 @@ STATIC_INLINE u_int32_t ByteSwap32(u_int32_t x)
STATIC_INLINE u_int64_t ByteSwap64(u_int64_t x) STATIC_INLINE u_int64_t ByteSwap64(u_int64_t x)
{ {
#ifdef ARCH_X86_64 #ifdef ARCH_X86_64
__asm("bswap %0" : "=r"(x) : "0"(x)); __asm("bswap %0" : "=r"(x) : "0"(x));
return x; return x;
#else #else
register union { register union {
__extension__ u_int64_t __ll; __extension__ u_int64_t __ll;
u_int32_t __l[2]; u_int32_t __l[2];
} __x; } __x;
asm("xchgl %0,%1" asm("xchgl %0,%1"
: "=r"(__x.__l[0]), "=r"(__x.__l[1]) : "=r"(__x.__l[0]), "=r"(__x.__l[1])
: "0"(bswap_32((unsigned long)x)), : "0"(bswap_32((unsigned long)x)),
"1"(bswap_32((unsigned long)(x >> 32)))); "1"(bswap_32((unsigned long)(x >> 32))));

4
scheme-boot/flisp.boot
View File

@ -1,4 +1,4 @@
(*banner* "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n" (*banner* "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|--\n\n"
*builtins* [0 0 0 0 0 0 0 0 0 0 0 0 #fn("7000r2|}<;" []) *builtins* [0 0 0 0 0 0 0 0 0 0 0 0 #fn("7000r2|}<;" [])
#fn("7000r2|}=;" []) #fn("7000r2|}=;" [])
#fn("7000r2|}>;" []) #fn("7000r2|}>;" [])
@ -64,7 +64,7 @@
with-bindings *output-stream* #fn(copy-list)]) catch #fn("7000r2c0qc13041;" [#fn("@000r1c0\x7fc1|L1c2c3c4|L2c5c6|L2c7c8L2L3c5c9|L2~L3L4c:|L2c;|L2L4L3L3;" [trycatch with-bindings *output-stream* #fn(copy-list)]) catch #fn("7000r2c0qc13041;" [#fn("@000r1c0\x7fc1|L1c2c3c4|L2c5c6|L2c7c8L2L3c5c9|L2~L3L4c:|L2c;|L2L4L3L3;" [trycatch
lambda if and pair? eq car quote thrown-value cadr caddr raise]) lambda if and pair? eq car quote thrown-value cadr caddr raise])
#fn(gensym)])) #fn(gensym)]))
*whitespace* "\t\n\v\f\r \u0085  ᠎           \u2028\u2029  　" 1+ *whitespace* "\t\n\v\f\r \u0085  \u180e           

  　" 1+
#fn("7000r1|aw;" [] 1+) 1- #fn("7000r1|ax;" [] 1-) 1arg-lambda? #fn("7000r1|aw;" [] 1+) 1- #fn("7000r1|ax;" [] 1-) 1arg-lambda?
#fn("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda #fn("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda
length=] 1arg-lambda?) length=] 1arg-lambda?)

64
scheme-core/aliases.scm
View File

@ -7,10 +7,10 @@
(define (set-symbol-value! s v) (set-top-level-value! s v)) (define (set-symbol-value! s v) (set-top-level-value! s v))
(define (eval x) (define (eval x)
((compile-thunk (expand ((compile-thunk (expand
(if (and (pair? x) (if (and (pair? x)
(equal? (car x) "noexpand")) (equal? (car x) "noexpand"))
(cadr x) (cadr x)
x))))) x)))))
(define (command-line) *argv*) (define (command-line) *argv*)
(define gensym (define gensym
@ -142,21 +142,21 @@
(define get-datum read) (define get-datum read)
(define (put-datum port x) (define (put-datum port x)
(with-bindings ((*print-readably* #t)) (with-bindings ((*print-readably* #t))
(write x port))) (write x port)))
(define (put-u8 port o) (io.write port (uint8 o))) (define (put-u8 port o) (io.write port (uint8 o)))
(define (put-string port s (start 0) (count #f)) (define (put-string port s (start 0) (count #f))
(let* ((start (string.inc s 0 start)) (let* ((start (string.inc s 0 start))
(end (if count (end (if count
(string.inc s start count) (string.inc s start count)
(sizeof s)))) (sizeof s))))
(io.write port s start (- end start)))) (io.write port s start (- end start))))
(define (io.skipws s) (define (io.skipws s)
(let ((c (io.peekc s))) (let ((c (io.peekc s)))
(if (and (not (eof-object? c)) (char-whitespace? c)) (if (and (not (eof-object? c)) (char-whitespace? c))
(begin (io.getc s) (begin (io.getc s)
(io.skipws s))))) (io.skipws s)))))
(define (with-output-to-file name thunk) (define (with-output-to-file name thunk)
(let ((f (file name :write :create :truncate))) (let ((f (file name :write :create :truncate)))
@ -173,12 +173,12 @@
(define (call-with-input-file name proc) (define (call-with-input-file name proc)
(let ((f (open-input-file name))) (let ((f (open-input-file name)))
(prog1 (proc f) (prog1 (proc f)
(io.close f)))) (io.close f))))
(define (call-with-output-file name proc) (define (call-with-output-file name proc)
(let ((f (open-output-file name))) (let ((f (open-output-file name)))
(prog1 (proc f) (prog1 (proc f)
(io.close f)))) (io.close f))))
(define (file-exists? f) (path.exists? f)) (define (file-exists? f) (path.exists? f))
(define (delete-file name) (void)) ; TODO (define (delete-file name) (void)) ; TODO
@ -187,8 +187,8 @@
(with-output-to port (princ x)) (with-output-to port (princ x))
#t) #t)
(define assertion-violation (define assertion-violation
(lambda args (lambda args
(display 'assertion-violation) (display 'assertion-violation)
(newline) (newline)
(display args) (display args)
@ -206,8 +206,8 @@
(define (assp pred lst) (define (assp pred lst)
(cond ((atom? lst) #f) (cond ((atom? lst) #f)
((pred (caar lst)) (car lst)) ((pred (caar lst)) (car lst))
(else (assp pred (cdr lst))))) (else (assp pred (cdr lst)))))
(define (for-all proc l . ls) (define (for-all proc l . ls)
(or (null? l) (or (null? l)
@ -218,7 +218,7 @@
(define (exists proc l . ls) (define (exists proc l . ls)
(and (not (null? l)) (and (not (null? l))
(or (apply proc (car l) (map car ls)) (or (apply proc (car l) (map car ls))
(apply exists proc (cdr l) (map cdr ls))))) (apply exists proc (cdr l) (map cdr ls)))))
(define ormap exists) (define ormap exists)
(define cons* list*) (define cons* list*)
@ -236,27 +236,27 @@
(define (dynamic-wind before thunk after) (define (dynamic-wind before thunk after)
(before) (before)
(unwind-protect (thunk) (unwind-protect (thunk)
(after))) (after)))
(let ((*properties* (table))) (let ((*properties* (table)))
(set! putprop (set! putprop
(lambda (sym key val) (lambda (sym key val)
(let ((sp (get *properties* sym #f))) (let ((sp (get *properties* sym #f)))
(if (not sp) (if (not sp)
(let ((t (table))) (let ((t (table)))
(put! *properties* sym t) (put! *properties* sym t)
(set! sp t))) (set! sp t)))
(put! sp key val)))) (put! sp key val))))
(set! getprop (set! getprop
(lambda (sym key) (lambda (sym key)
(let ((sp (get *properties* sym #f))) (let ((sp (get *properties* sym #f)))
(and sp (get sp key #f))))) (and sp (get sp key #f)))))
(set! remprop (set! remprop
(lambda (sym key) (lambda (sym key)
(let ((sp (get *properties* sym #f))) (let ((sp (get *properties* sym #f)))
(and sp (has? sp key) (del! sp key)))))) (and sp (has? sp key) (del! sp key))))))
; --- gambit ; --- gambit
@ -269,7 +269,7 @@
(define (include f) (load f)) (define (include f) (load f))
(define (with-exception-catcher hand thk) (define (with-exception-catcher hand thk)
(trycatch (thk) (trycatch (thk)
(lambda (e) (hand e)))) (lambda (e) (hand e))))
(define (current-exception-handler) (define (current-exception-handler)
; close enough ; close enough

1022
scheme-core/compiler.scm
View File

File diff suppressed because it is too large Load Diff

10
scheme-core/mkboot0.scm
View File

@ -10,11 +10,11 @@
(let ((in (file inf :read))) (let ((in (file inf :read)))
(let next ((E (read in))) (let next ((E (read in)))
(if (not (io.eof? in)) (if (not (io.eof? in))
(begin (print (compile-thunk (expand E))) (begin (print (compile-thunk (expand E)))
(princ "\n") (princ "\n")
(next (read in))))) (next (read in)))))
(io.close in))) (io.close in)))
(for-each (lambda (file) (for-each (lambda (file)
(compile-file file)) (compile-file file))
(cdr *argv*)) (cdr *argv*))

938
scheme-core/system.scm
View File

File diff suppressed because it is too large Load Diff

146
scheme-examples/bq.scm
View File

@ -1,76 +1,76 @@
(define (bq-process2 x d) (define (bq-process2 x d)
(define (splice-form? x) (define (splice-form? x)
(or (and (pair? x) (or (eq? (car x) 'unquote-splicing) (or (and (pair? x) (or (eq? (car x) 'unquote-splicing)
(eq? (car x) 'unquote-nsplicing) (eq? (car x) 'unquote-nsplicing)
(and (eq? (car x) 'unquote) (and (eq? (car x) 'unquote)
(length> x 2)))) (length> x 2))))
(eq? x 'unquote))) (eq? x 'unquote)))
;; bracket without splicing ;; bracket without splicing
(define (bq-bracket1 x) (define (bq-bracket1 x)
(if (and (pair? x) (eq? (car x) 'unquote)) (if (and (pair? x) (eq? (car x) 'unquote))
(if (= d 0) (if (= d 0)
(cadr x) (cadr x)
(list cons ''unquote (list cons ''unquote
(bq-process2 (cdr x) (- d 1)))) (bq-process2 (cdr x) (- d 1))))
(bq-process2 x d))) (bq-process2 x d)))
(define (bq-bracket x) (define (bq-bracket x)
(cond ((atom? x) (list list (bq-process2 x d))) (cond ((atom? x) (list list (bq-process2 x d)))
((eq? (car x) 'unquote) ((eq? (car x) 'unquote)
(if (= d 0) (if (= d 0)
(cons list (cdr x)) (cons list (cdr x))
(list list (list cons ''unquote (list list (list cons ''unquote
(bq-process2 (cdr x) (- d 1)))))) (bq-process2 (cdr x) (- d 1))))))
((eq? (car x) 'unquote-splicing) ((eq? (car x) 'unquote-splicing)
(if (= d 0) (if (= d 0)
(list 'copy-list (cadr x)) (list 'copy-list (cadr x))
(list list (list list ''unquote-splicing (list list (list list ''unquote-splicing
(bq-process2 (cadr x) (- d 1)))))) (bq-process2 (cadr x) (- d 1))))))
((eq? (car x) 'unquote-nsplicing) ((eq? (car x) 'unquote-nsplicing)
(if (= d 0) (if (= d 0)
(cadr x) (cadr x)
(list list (list list ''unquote-nsplicing (list list (list list ''unquote-nsplicing
(bq-process2 (cadr x) (- d 1)))))) (bq-process2 (cadr x) (- d 1))))))
(else (list list (bq-process2 x d))))) (else (list list (bq-process2 x d)))))
(cond ((symbol? x) (list 'quote x)) (cond ((symbol? x) (list 'quote x))
((vector? x) ((vector? x)
(let ((body (bq-process2 (vector->list x) d))) (let ((body (bq-process2 (vector->list x) d)))
(if (eq? (car body) list) (if (eq? (car body) list)
(cons vector (cdr body)) (cons vector (cdr body))
(list apply vector body)))) (list apply vector body))))
((atom? x) x) ((atom? x) x)
((eq? (car x) 'quasiquote) ((eq? (car x) 'quasiquote)
(list list ''quasiquote (bq-process2 (cadr x) (+ d 1)))) (list list ''quasiquote (bq-process2 (cadr x) (+ d 1))))
((eq? (car x) 'unquote) ((eq? (car x) 'unquote)
(if (and (= d 0) (length= x 2)) (if (and (= d 0) (length= x 2))
(cadr x) (cadr x)
(list cons ''unquote (bq-process2 (cdr x) (- d 1))))) (list cons ''unquote (bq-process2 (cdr x) (- d 1)))))
((or (> d 0) (not (any splice-form? x))) ((or (> d 0) (not (any splice-form? x)))
(let ((lc (lastcdr x)) (let ((lc (lastcdr x))
(forms (map bq-bracket1 x))) (forms (map bq-bracket1 x)))
(if (null? lc) (if (null? lc)
(cons list forms) (cons list forms)
(if (null? (cdr forms)) (if (null? (cdr forms))
(list cons (car forms) (bq-process2 lc d)) (list cons (car forms) (bq-process2 lc d))
(nconc (cons list* forms) (list (bq-process2 lc d))))))) (nconc (cons list* forms) (list (bq-process2 lc d)))))))
(else (else
(let loop ((p x) (q ())) (let loop ((p x) (q ()))
(cond ((null? p) ;; proper list (cond ((null? p) ;; proper list
(cons 'nconc (reverse! q))) (cons 'nconc (reverse! q)))
((pair? p) ((pair? p)
(cond ((eq? (car p) 'unquote) (cond ((eq? (car p) 'unquote)
;; (... . ,x) ;; (... . ,x)
(cons 'nconc (cons 'nconc
(nreconc q (nreconc q
(if (= d 0) (if (= d 0)
(cdr p) (cdr p)
(list (list list ''unquote) (list (list list ''unquote)
(bq-process2 (cdr p) (bq-process2 (cdr p)
(- d 1))))))) (- d 1)))))))
(else (else
(loop (cdr p) (cons (bq-bracket (car p)) q))))) (loop (cdr p) (cons (bq-bracket (car p)) q)))))
(else (else
;; (... . x) ;; (... . x)
(cons 'nconc (reverse! (cons (bq-process2 p d) q))))))))) (cons 'nconc (reverse! (cons (bq-process2 p d) q)))))))))
#| #|
tests tests
@ -98,25 +98,25 @@ tests
(define (bq-process0 x d) (define (bq-process0 x d)
(define (bq-bracket x) (define (bq-bracket x)
(cond ((and (pair? x) (eq? (car x) 'unquote)) (cond ((and (pair? x) (eq? (car x) 'unquote))
(if (= d 0) (if (= d 0)
(cons list (cdr x)) (cons list (cdr x))
(list list (list cons ''unquote (list list (list cons ''unquote
(bq-process0 (cdr x) (- d 1)))))) (bq-process0 (cdr x) (- d 1))))))
((and (pair? x) (eq? (car x) 'unquote-splicing)) ((and (pair? x) (eq? (car x) 'unquote-splicing))
(if (= d 0) (if (= d 0)
(list 'copy-list (cadr x)) (list 'copy-list (cadr x))
(list list (list list ''unquote-splicing (list list (list list ''unquote-splicing
(bq-process0 (cadr x) (- d 1)))))) (bq-process0 (cadr x) (- d 1))))))
(else (list list (bq-process0 x d))))) (else (list list (bq-process0 x d)))))
(cond ((symbol? x) (list 'quote x)) (cond ((symbol? x) (list 'quote x))
((atom? x) x) ((atom? x) x)
((eq? (car x) 'quasiquote) ((eq? (car x) 'quasiquote)
(list list ''quasiquote (bq-process0 (cadr x) (+ d 1)))) (list list ''quasiquote (bq-process0 (cadr x) (+ d 1))))
((eq? (car x) 'unquote) ((eq? (car x) 'unquote)
(if (and (= d 0) (length= x 2)) (if (and (= d 0) (length= x 2))
(cadr x) (cadr x)
(list cons ''unquote (bq-process0 (cdr x) (- d 1))))) (list cons ''unquote (bq-process0 (cdr x) (- d 1)))))
(else (else
(cons 'nconc (map bq-bracket x))))) (cons 'nconc (map bq-bracket x)))))
#t #t

13
scheme-examples/cps.scm
View File

@ -3,8 +3,8 @@
(cond ((atom? forms) `(,k ,forms)) (cond ((atom? forms) `(,k ,forms))
((null? (cdr forms)) (cps- (car forms) k)) ((null? (cdr forms)) (cps- (car forms) k))
(#t (let ((_ (gensym))) ; var to bind ignored value (#t (let ((_ (gensym))) ; var to bind ignored value
(cps- (car forms) `(lambda (,_) (cps- (car forms) `(lambda (,_)
,(begin->cps (cdr forms) k))))))) ,(begin->cps (cdr forms) k)))))))
(define-macro (lambda/cc args body) (define-macro (lambda/cc args body)
`(cons 'lambda/cc (lambda ,args ,body))) `(cons 'lambda/cc (lambda ,args ,body)))
@ -24,7 +24,7 @@
`(define (,name f k ,@args) `(define (,name f k ,@args)
(if (and (pair? f) (eq (car f) 'lambda/cc)) (if (and (pair? f) (eq (car f) 'lambda/cc))
((cdr f) k ,@args) ((cdr f) k ,@args)
(k (f ,@args)))))) (k (f ,@args))))))
(def-funcall/cc-n ()) (def-funcall/cc-n ())
(def-funcall/cc-n (a0)) (def-funcall/cc-n (a0))
(def-funcall/cc-n (a0 a1)) (def-funcall/cc-n (a0 a1))
@ -242,8 +242,8 @@
(define-macro (define-generator form . body) (define-macro (define-generator form . body)
(let ((ko (gensym)) (let ((ko (gensym))
(cur (gensym)) (cur (gensym))
(name (car form)) (name (car form))
(args (cdr form))) (args (cdr form)))
`(define (,name ,@args) `(define (,name ,@args)
(let ((,ko #f) (let ((,ko #f)
(,cur #f)) (,cur #f))
@ -284,7 +284,8 @@ todo:
* handle dotted arglists in lambda * handle dotted arglists in lambda
- optimize constant functions, e.g. (funcall/cc-0 #:g65 (lambda (#:g58) 'done)) - optimize constant functions, e.g.
(funcall/cc-0 #:g65 (lambda (#:g58) 'done))
- implement CPS version of apply - implement CPS version of apply

28
scheme-examples/rule30.scm
View File

@ -2,24 +2,24 @@
(define (rule30-step b) (define (rule30-step b)
(let ((L (ash b -1)) (let ((L (ash b -1))
(R (ash b 1))) (R (ash b 1)))
(let ((~b (lognot b)) (let ((~b (lognot b))
(~L (lognot L)) (~L (lognot L))
(~R (lognot R))) (~R (lognot R)))
(logior (logand L ~b ~R) (logior (logand L ~b ~R)
(logand ~L b R) (logand ~L b R)
(logand ~L b ~R) (logand ~L b ~R)
(logand ~L ~b R))))) (logand ~L ~b R)))))
(define (bin-draw s) (define (bin-draw s)
(string.map (lambda (c) (case c (string.map (lambda (c) (case c
(#\1 #\#) (#\1 #\#)
(#\0 #\ ) (#\0 #\ )
(else c))) (else c)))
s)) s))
(for-each (lambda (n) (for-each (lambda (n)
(begin (begin
(princ (bin-draw (string.lpad (number->string n 2) 63 #\0))) (princ (bin-draw (string.lpad (number->string n 2) 63 #\0)))
(newline))) (newline)))
(nestlist rule30-step (uint64 0x0000000080000000) 32)) (nestlist rule30-step (uint64 0x0000000080000000) 32))

8
scheme-lib/lazy.scm
View File

@ -34,14 +34,14 @@
(let ((content (unbox promise))) (let ((content (unbox promise)))
(case (car content) (case (car content)
((eager) (cdr content)) ((eager) (cdr content))
((lazy) (let* ((promise* ((cdr content))) ((lazy) (let* ((promise* ((cdr content)))
(content (unbox promise))) ; * (content (unbox promise))) ; *
(if (not (eqv? (car content) 'eager)) ; * (if (not (eqv? (car content) 'eager)) ; *
(begin (set-car! content (car (unbox promise*))) (begin (set-car! content (car (unbox promise*)))
(set-cdr! content (cdr (unbox promise*))) (set-cdr! content (cdr (unbox promise*)))
(set-box! promise* content))) (set-box! promise* content)))
(force promise)))))) (force promise))))))
; (*) These two lines re-fetch and check the original promise in case ; (*) These two lines re-fetch and check the original promise in case
; the first line of the let* caused it to be forced. For an example ; the first line of the let* caused it to be forced. For an example
; where this happens, see reentrancy test 3 below. ; where this happens, see reentrancy test 3 below.

55
scheme-lib/psyntax.scm
View File

@ -48,7 +48,7 @@
;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can ;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can
;;; also be found online at http://www.scheme.com/csug/. They are ;;; also be found online at http://www.scheme.com/csug/. They are
;;; described briefly here as well. ;;; described briefly here as well.
;;; All are definitions and may appear where and only where other ;;; All are definitions and may appear where and only where other
;;; definitions may appear. modules may be named: ;;; definitions may appear. modules may be named:
;;; ;;;
@ -94,36 +94,36 @@
;;; drop-prefix, rename, and alias. ;;; drop-prefix, rename, and alias.
;;; ;;;
;;; (import (only m x y)) ;;; (import (only m x y))
;;; ;;;
;;; imports x and y (and nothing else) from m. ;;; imports x and y (and nothing else) from m.
;;; ;;;
;;; (import (except m x y)) ;;; (import (except m x y))
;;; ;;;
;;; imports all of m's imports except for x and y. ;;; imports all of m's imports except for x and y.
;;; ;;;
;;; (import (add-prefix (only m x y) m:)) ;;; (import (add-prefix (only m x y) m:))
;;; ;;;
;;; imports x and y as m:x and m:y. ;;; imports x and y as m:x and m:y.
;;; ;;;
;;; (import (drop-prefix m foo:)) ;;; (import (drop-prefix m foo:))
;;; ;;;
;;; imports all of m's imports, dropping the common foo: prefix ;;; imports all of m's imports, dropping the common foo: prefix
;;; (which must appear on all of m's exports). ;;; (which must appear on all of m's exports).
;;; ;;;
;;; (import (rename (except m a b) (m-c c) (m-d d))) ;;; (import (rename (except m a b) (m-c c) (m-d d)))
;;; ;;;
;;; imports all of m's imports except for x and y, renaming c ;;; imports all of m's imports except for x and y, renaming c
;;; m-c and d m-d. ;;; m-c and d m-d.
;;; ;;;
;;; (import (alias (except m a b) (m-c c) (m-d d))) ;;; (import (alias (except m a b) (m-c c) (m-d d)))
;;; ;;;
;;; imports all of m's imports except for x and y, with additional ;;; imports all of m's imports except for x and y, with additional
;;; aliases m-c for c and m-d for d. ;;; aliases m-c for c and m-d for d.
;;; ;;;
;;; multiple imports may be specified with one import form: ;;; multiple imports may be specified with one import form:
;;; ;;;
;;; (import (except m1 x) (only m2 x)) ;;; (import (except m1 x) (only m2 x))
;;; ;;;
;;; imports all of m1's exports except for x plus x from m2. ;;; imports all of m1's exports except for x plus x from m2.
;;; Another form, meta, may be used as a prefix for any definition and ;;; Another form, meta, may be used as a prefix for any definition and
@ -165,7 +165,7 @@
;;; meta definitions propagate through macro expansion, so one can write, ;;; meta definitions propagate through macro expansion, so one can write,
;;; for example: ;;; for example:
;;; ;;;
;;; (module (a) ;;; (module (a)
;;; (meta define-structure (foo x)) ;;; (meta define-structure (foo x))
;;; (define-syntax a ;;; (define-syntax a
@ -173,17 +173,17 @@
;;; (lambda (x) ;;; (lambda (x)
;;; (foo-x q))))) ;;; (foo-x q)))))
;;; a -> q ;;; a -> q
;;; ;;;
;;; where define-record is a macro that expands into a set of defines. ;;; where define-record is a macro that expands into a set of defines.
;;; ;;;
;;; It is also sometimes convenient to write ;;; It is also sometimes convenient to write
;;; ;;;
;;; (meta begin defn ...) ;;; (meta begin defn ...)
;;; ;;;
;;; or ;;; or
;;; ;;;
;;; (meta module {exports} defn ...) ;;; (meta module {exports} defn ...)
;;; ;;;
;;; to create groups of meta bindings. ;;; to create groups of meta bindings.
;;; Another form, alias, is used to create aliases from one identifier ;;; Another form, alias, is used to create aliases from one identifier
@ -1166,7 +1166,7 @@
(and (same-marks? marks (join-marks new-marks (wrap-marks top-wrap))) new)) (and (same-marks? marks (join-marks new-marks (wrap-marks top-wrap))) new))
((same-marks? marks (join-marks new-marks (wrap-marks (syntax-object-wrap new)))) new) ((same-marks? marks (join-marks new-marks (wrap-marks (syntax-object-wrap new)))) new)
(else #f))))))) (else #f)))))))
(define store-import-binding (define store-import-binding
(lambda (id token new-marks) (lambda (id token new-marks)
(define cons-id (define cons-id
@ -1186,7 +1186,7 @@
(join-marks new-marks (id-marks id)) (join-marks new-marks (id-marks id))
(id-subst id)))))) (id-subst id))))))
(let ((sym (id-sym-name id))) (let ((sym (id-sym-name id)))
; no need to record bindings mapping symbol to self, since this ; no need to record bindings mapping symbol to self, since this
; assumed by default. ; assumed by default.
(unless (eq? id sym) (unless (eq? id sym)
(let ((marks (id-marks id))) (let ((marks (id-marks id)))
@ -1483,7 +1483,7 @@
(lambda (i.sym i.marks j.sym j.marks) (lambda (i.sym i.marks j.sym j.marks)
(and (eq? i.sym j.sym) (and (eq? i.sym j.sym)
(same-marks? i.marks j.marks)))) (same-marks? i.marks j.marks))))
(define bound-id=? (define bound-id=?
(lambda (i j) (lambda (i j)
(help-bound-id=? (id-sym-name i) (id-marks i) (id-sym-name j) (id-marks j)))) (help-bound-id=? (id-sym-name i) (id-marks i) (id-sym-name j) (id-marks j))))
@ -1952,7 +1952,7 @@
((define-syntax-form) ((define-syntax-form)
(let ((sym (generate-id (id-sym-name id)))) (let ((sym (generate-id (id-sym-name id))))
(process-exports fexports (process-exports fexports
(lambda () (lambda ()
(let ((local-label (get-indirect-label label))) (let ((local-label (get-indirect-label label)))
(set-indirect-label! label sym) (set-indirect-label! label sym)
(cons (cons
@ -2711,7 +2711,7 @@
(unless label (unless label
(syntax-error id "exported identifier not visible")) (syntax-error id "exported identifier not visible"))
label))) label)))
(define do-import! (define do-import!
(lambda (import-iface ribcage) (lambda (import-iface ribcage)
(let ((ie (interface-exports (import-interface-interface import-iface)))) (let ((ie (interface-exports (import-interface-interface import-iface))))
@ -3434,7 +3434,7 @@
(let ((id (if (pair? x) (car x) x))) (let ((id (if (pair? x) (car x) x)))
(make-syntax-object (make-syntax-object
(syntax-object->datum id) (syntax-object->datum id)
(let ((marks (join-marks new-marks (wrap-marks (syntax-object-wrap id))))) (let ((marks (join-marks new-marks (wrap-marks (syntax-object-wrap id)))))
(make-wrap marks (make-wrap marks
; the anti mark should always be present at the head ; the anti mark should always be present at the head
; of new-marks, but we paranoically check anyway ; of new-marks, but we paranoically check anyway
@ -3578,7 +3578,7 @@
(put-cte-hook 'import (put-cte-hook 'import
(lambda (orig) (lambda (orig)
($import-help orig #f))) ($import-help orig #f)))
(put-cte-hook 'import-only (put-cte-hook 'import-only
(lambda (orig) (lambda (orig)
($import-help orig #t))) ($import-help orig #t)))
@ -3725,7 +3725,7 @@
; unique mark (in tmp-wrap) to distinguish from non-temporaries ; unique mark (in tmp-wrap) to distinguish from non-temporaries
tmp-wrap)) tmp-wrap))
ls)))) ls))))
(set! free-identifier=? (set! free-identifier=?
(lambda (x y) (lambda (x y)
(arg-check nonsymbol-id? x 'free-identifier=?) (arg-check nonsymbol-id? x 'free-identifier=?)
@ -4292,4 +4292,3 @@
((set! var val) (syntax exp2)) ((set! var val) (syntax exp2))
((id x (... ...)) (syntax (exp1 x (... ...)))) ((id x (... ...)) (syntax (exp1 x (... ...))))
(id (identifier? (syntax id)) (syntax exp1)))))))) (id (identifier? (syntax id)) (syntax exp1))))))))

214
scheme-lib/sort.scm
View File

@ -24,23 +24,23 @@
(define (sorted? seq less? . opt-key) (define (sorted? seq less? . opt-key)
(define key (if (null? opt-key) identity (car opt-key))) (define key (if (null? opt-key) identity (car opt-key)))
(cond ((null? seq) #t) (cond ((null? seq) #t)
((array? seq) ((array? seq)
(let ((dimax (+ -1 (car (array-dimensions seq))))) (let ((dimax (+ -1 (car (array-dimensions seq)))))
(or (<= dimax 1) (or (<= dimax 1)
(let loop ((idx (+ -1 dimax)) (let loop ((idx (+ -1 dimax))
(last (key (array-ref seq dimax)))) (last (key (array-ref seq dimax))))
(or (negative? idx) (or (negative? idx)
(let ((nxt (key (array-ref seq idx)))) (let ((nxt (key (array-ref seq idx))))
(and (less? nxt last) (and (less? nxt last)
(loop (+ -1 idx) nxt)))))))) (loop (+ -1 idx) nxt))))))))
((null? (cdr seq)) #t) ((null? (cdr seq)) #t)
(else (else
(let loop ((last (key (car seq))) (let loop ((last (key (car seq)))
(next (cdr seq))) (next (cdr seq)))
(or (null? next) (or (null? next)
(let ((nxt (key (car next)))) (let ((nxt (key (car next))))
(and (not (less? nxt last)) (and (not (less? nxt last))
(loop nxt (cdr next))))))))) (loop nxt (cdr next)))))))))
;;; (merge a b less?) ;;; (merge a b less?)
;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?) ;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
@ -51,49 +51,49 @@
(define (merge a b less? . opt-key) (define (merge a b less? . opt-key)
(define key (if (null? opt-key) identity (car opt-key))) (define key (if (null? opt-key) identity (car opt-key)))
(cond ((null? a) b) (cond ((null? a) b)
((null? b) a) ((null? b) a)
(else (else
(let loop ((x (car a)) (kx (key (car a))) (a (cdr a)) (let loop ((x (car a)) (kx (key (car a))) (a (cdr a))
(y (car b)) (ky (key (car b))) (b (cdr b))) (y (car b)) (ky (key (car b))) (b (cdr b)))
;; The loop handles the merging of non-empty lists. It has ;; The loop handles the merging of non-empty lists. It has
;; been written this way to save testing and car/cdring. ;; been written this way to save testing and car/cdring.
(if (less? ky kx) (if (less? ky kx)
(if (null? b) (if (null? b)
(cons y (cons x a)) (cons y (cons x a))
(cons y (loop x kx a (car b) (key (car b)) (cdr b)))) (cons y (loop x kx a (car b) (key (car b)) (cdr b))))
;; x <= y ;; x <= y
(if (null? a) (if (null? a)
(cons x (cons y b)) (cons x (cons y b))
(cons x (loop (car a) (key (car a)) (cdr a) y ky b)))))))) (cons x (loop (car a) (key (car a)) (cdr a) y ky b))))))))
(define (sort:merge! a b less? key) (define (sort:merge! a b less? key)
(define (loop r a kcara b kcarb) (define (loop r a kcara b kcarb)
(cond ((less? kcarb kcara) (cond ((less? kcarb kcara)
(set-cdr! r b) (set-cdr! r b)
(if (null? (cdr b)) (if (null? (cdr b))
(set-cdr! b a) (set-cdr! b a)
(loop b a kcara (cdr b) (key (cadr b))))) (loop b a kcara (cdr b) (key (cadr b)))))
(else ; (car a) <= (car b) (else ; (car a) <= (car b)
(set-cdr! r a) (set-cdr! r a)
(if (null? (cdr a)) (if (null? (cdr a))
(set-cdr! a b) (set-cdr! a b)
(loop a (cdr a) (key (cadr a)) b kcarb))))) (loop a (cdr a) (key (cadr a)) b kcarb)))))
(cond ((null? a) b) (cond ((null? a) b)
((null? b) a) ((null? b) a)
(else (else
(let ((kcara (key (car a))) (let ((kcara (key (car a)))
(kcarb (key (car b)))) (kcarb (key (car b))))
(cond (cond
((less? kcarb kcara) ((less? kcarb kcara)
(if (null? (cdr b)) (if (null? (cdr b))
(set-cdr! b a) (set-cdr! b a)
(loop b a kcara (cdr b) (key (cadr b)))) (loop b a kcara (cdr b) (key (cadr b))))
b) b)
(else ; (car a) <= (car b) (else ; (car a) <= (car b)
(if (null? (cdr a)) (if (null? (cdr a))
(set-cdr! a b) (set-cdr! a b)
(loop a (cdr a) (key (cadr a)) b kcarb)) (loop a (cdr a) (key (cadr a)) b kcarb))
a)))))) a))))))
;;; takes two sorted lists a and b and smashes their cdr fields to form a ;;; takes two sorted lists a and b and smashes their cdr fields to form a
;;; single sorted list including the elements of both. ;;; single sorted list including the elements of both.
@ -106,39 +106,39 @@
(define keyer (if key car identity)) (define keyer (if key car identity))
(define (step n) (define (step n)
(cond ((> n 2) (let* ((j (quotient n 2)) (cond ((> n 2) (let* ((j (quotient n 2))
(a (step j)) (a (step j))
(k (- n j)) (k (- n j))
(b (step k))) (b (step k)))
(sort:merge! a b less? keyer))) (sort:merge! a b less? keyer)))
((= n 2) (let ((x (car seq)) ((= n 2) (let ((x (car seq))
(y (cadr seq)) (y (cadr seq))
(p seq)) (p seq))
(set! seq (cddr seq)) (set! seq (cddr seq))
(cond ((less? (keyer y) (keyer x)) (cond ((less? (keyer y) (keyer x))
(set-car! p y) (set-car! p y)
(set-car! (cdr p) x))) (set-car! (cdr p) x)))
(set-cdr! (cdr p) '()) (set-cdr! (cdr p) '())
p)) p))
((= n 1) (let ((p seq)) ((= n 1) (let ((p seq))
(set! seq (cdr seq)) (set! seq (cdr seq))
(set-cdr! p '()) (set-cdr! p '())
p)) p))
(else '()))) (else '())))
(define (key-wrap! lst) (define (key-wrap! lst)
(cond ((null? lst)) (cond ((null? lst))
(else (set-car! lst (cons (key (car lst)) (car lst))) (else (set-car! lst (cons (key (car lst)) (car lst)))
(key-wrap! (cdr lst))))) (key-wrap! (cdr lst)))))
(define (key-unwrap! lst) (define (key-unwrap! lst)
(cond ((null? lst)) (cond ((null? lst))
(else (set-car! lst (cdar lst)) (else (set-car! lst (cdar lst))
(key-unwrap! (cdr lst))))) (key-unwrap! (cdr lst)))))
(cond (key (cond (key
(key-wrap! seq) (key-wrap! seq)
(set! seq (step (length seq))) (set! seq (step (length seq)))
(key-unwrap! seq) (key-unwrap! seq)
seq) seq)
(else (else
(step (length seq))))) (step (length seq)))))
(define (rank-1-array->list array) (define (rank-1-array->list array)
(define dimensions (array-dimensions array)) (define dimensions (array-dimensions array))
@ -156,22 +156,22 @@
(define (sort! seq less? . opt-key) (define (sort! seq less? . opt-key)
(define key (if (null? opt-key) #f (car opt-key))) (define key (if (null? opt-key) #f (car opt-key)))
(cond ((array? seq) (cond ((array? seq)
(let ((dims (array-dimensions seq))) (let ((dims (array-dimensions seq)))
(do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key) (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
(cdr sorted)) (cdr sorted))
(i 0 (+ i 1))) (i 0 (+ i 1)))
((null? sorted) seq) ((null? sorted) seq)
(array-set! seq (car sorted) i)))) (array-set! seq (car sorted) i))))
(else ; otherwise, assume it is a list (else ; otherwise, assume it is a list
(let ((ret (sort:sort-list! seq less? key))) (let ((ret (sort:sort-list! seq less? key)))
(if (not (eq? ret seq)) (if (not (eq? ret seq))
(do ((crt ret (cdr crt))) (do ((crt ret (cdr crt)))
((eq? (cdr crt) seq) ((eq? (cdr crt) seq)
(set-cdr! crt ret) (set-cdr! crt ret)
(let ((scar (car seq)) (scdr (cdr seq))) (let ((scar (car seq)) (scdr (cdr seq)))
(set-car! seq (car ret)) (set-cdr! seq (cdr ret)) (set-car! seq (car ret)) (set-cdr! seq (cdr ret))
(set-car! ret scar) (set-cdr! ret scdr))))) (set-car! ret scar) (set-cdr! ret scdr)))))
seq)))) seq))))
;;; (sort sequence less?) ;;; (sort sequence less?)
;;; sorts a array, string, or list non-destructively. It does this ;;; sorts a array, string, or list non-destructively. It does this
@ -183,11 +183,11 @@
(define (sort seq less? . opt-key) (define (sort seq less? . opt-key)
(define key (if (null? opt-key) #f (car opt-key))) (define key (if (null? opt-key) #f (car opt-key)))
(cond ((array? seq) (cond ((array? seq)
(let ((dims (array-dimensions seq))) (let ((dims (array-dimensions seq)))
(define newra (apply make-array seq dims)) (define newra (apply make-array seq dims))
(do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key) (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
(cdr sorted)) (cdr sorted))
(i 0 (+ i 1))) (i 0 (+ i 1)))
((null? sorted) newra) ((null? sorted) newra)
(array-set! newra (car sorted) i)))) (array-set! newra (car sorted) i))))
(else (sort:sort-list! (append seq '()) less? key)))) (else (sort:sort-list! (append seq '()) less? key))))

116
scheme-tests/ast/asttools.scm
View File

@ -11,8 +11,8 @@
(define (index-of item lst start) (define (index-of item lst start)
(cond ((null? lst) #f) (cond ((null? lst) #f)
((eq item (car lst)) start) ((eq item (car lst)) start)
(#t (index-of item (cdr lst) (+ start 1))))) (#t (index-of item (cdr lst) (+ start 1)))))
(define (each f l) (define (each f l)
(if (null? l) l (if (null? l) l
@ -41,31 +41,33 @@
(f t zero) (f t zero)
(f t (foldl t (lambda (e state) (foldtree-post f e state)) zero)))) (f t (foldl t (lambda (e state) (foldtree-post f e state)) zero))))
; general tree transformer ;; general tree transformer
; folds in preorder (foldtree-pre), maps in postorder (maptree-post) ;;
; therefore state changes occur immediately, just by looking at the current node, ;; Folds in preorder (foldtree-pre), maps in postorder (maptree-post).
; while transformation follows evaluation order. this seems to be the most natural ;; Therefore state changes occur immediately, just by looking at the current
; approach. ;; node, while transformation follows evaluation order. This seems to be the
; (mapper tree state) - should return transformed tree given current state ;; most natural approach.
; (folder tree state) - should return new state ;;
;; (mapper tree state) - should return transformed tree given current state
;; (folder tree state) - should return new state
(define (map&fold t zero mapper folder) (define (map&fold t zero mapper folder)
(let ((head (and (pair? t) (car t)))) (let ((head (and (pair? t) (car t))))
(cond ((eq? head 'quote) (cond ((eq? head 'quote)
t) t)
((or (eq? head 'the) (eq? head 'meta)) ((or (eq? head 'the) (eq? head 'meta))
(list head (list head
(cadr t) (cadr t)
(map&fold (caddr t) zero mapper folder))) (map&fold (caddr t) zero mapper folder)))
(else (else
(let ((new-s (folder t zero))) (let ((new-s (folder t zero)))
(mapper (mapper
(if (pair? t) (if (pair? t)
; head symbol is a tag; never transform it ; head symbol is a tag; never transform it
(cons (car t) (cons (car t)
(map (lambda (e) (map&fold e new-s mapper folder)) (map (lambda (e) (map&fold e new-s mapper folder))
(cdr t))) (cdr t)))
t) t)
new-s)))))) new-s))))))
; convert to proper list, i.e. remove "dots", and append ; convert to proper list, i.e. remove "dots", and append
(define (append.2 l tail) (define (append.2 l tail)
@ -77,11 +79,11 @@
; env is a list of lexical variables in effect at that point. ; env is a list of lexical variables in effect at that point.
(define (lexical-walk f t) (define (lexical-walk f t)
(map&fold t () f (map&fold t () f
(lambda (tree state) (lambda (tree state)
(if (and (eq? (car t) 'lambda) (if (and (eq? (car t) 'lambda)
(pair? (cdr t))) (pair? (cdr t)))
(append.2 (cadr t) state) (append.2 (cadr t) state)
state)))) state))))
; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e) ; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
(define (flatten-left-op op e) (define (flatten-left-op op e)
@ -110,14 +112,14 @@
((pair? e) ((pair? e)
(if (eq (car e) 'quote) (if (eq (car e) 'quote)
e e
(let* ((newvs (and (eq (car e) 'lambda) (cadr e))) (let* ((newvs (and (eq (car e) 'lambda) (cadr e)))
(newenv (if newvs (cons newvs env) env))) (newenv (if newvs (cons newvs env) env)))
(if newvs (if newvs
(cons 'lambda (cons 'lambda
(cons (cadr e) (cons (cadr e)
(map (lambda (se) (lvc- se newenv)) (map (lambda (se) (lvc- se newenv))
(cddr e)))) (cddr e))))
(map (lambda (se) (lvc- se env)) e))))) (map (lambda (se) (lvc- se env)) e)))))
(#t e))) (#t e)))
(define (lexical-var-conversion e) (define (lexical-var-conversion e)
(lvc- e ())) (lvc- e ()))
@ -125,32 +127,32 @@
; convert let to lambda ; convert let to lambda
(define (let-expand e) (define (let-expand e)
(maptree-post (lambda (n) (maptree-post (lambda (n)
(if (and (pair? n) (eq (car n) 'let)) (if (and (pair? n) (eq (car n) 'let))
`((lambda ,(map car (cadr n)) ,@(cddr n)) `((lambda ,(map car (cadr n)) ,@(cddr n))
,@(map cadr (cadr n))) ,@(map cadr (cadr n)))
n)) n))
e)) e))
; alpha renaming ; alpha renaming
; transl is an assoc list ((old-sym-name . new-sym-name) ...) ; transl is an assoc list ((old-sym-name . new-sym-name) ...)
(define (alpha-rename e transl) (define (alpha-rename e transl)
(map&fold e (map&fold e
() ()
; mapper: replace symbol if unbound ; mapper: replace symbol if unbound
(lambda (t env) (lambda (t env)
(if (symbol? t) (if (symbol? t)
(let ((found (assq t transl))) (let ((found (assq t transl)))
(if (and found (if (and found
(not (memq t env))) (not (memq t env)))
(cdr found) (cdr found)
t)) t))
t)) t))
; folder: add locals to environment if entering a new scope ; folder: add locals to environment if entering a new scope
(lambda (t env) (lambda (t env)
(if (and (pair? t) (or (eq? (car t) 'let) (if (and (pair? t) (or (eq? (car t) 'let)
(eq? (car t) 'lambda))) (eq? (car t) 'lambda)))
(append (cadr t) env) (append (cadr t) env)
env)))) env))))
; flatten op with any associativity ; flatten op with any associativity
(define-macro (flatten-all-op op e) (define-macro (flatten-all-op op e)

154
scheme-tests/ast/match-lsp.scm
View File

@ -6,8 +6,8 @@
(if (null? lst) (if (null? lst)
() ()
(cons (car lst) (cons (car lst)
(filter (lambda (x) (not (eq x (car lst)))) (filter (lambda (x) (not (eq x (car lst))))
(unique (cdr lst)))))) (unique (cdr lst))))))
; list of special pattern symbols that cannot be variable names ; list of special pattern symbols that cannot be variable names
(define metasymbols '(_ ...)) (define metasymbols '(_ ...))
@ -40,44 +40,44 @@
; ;
(define (match- p expr state) (define (match- p expr state)
(cond ((symbol? p) (cond ((symbol? p)
(cond ((eq p '_) state) (cond ((eq p '_) state)
(#t (#t
(let ((capt (assq p state))) (let ((capt (assq p state)))
(if capt (if capt
(and (equal? expr (cdr capt)) state) (and (equal? expr (cdr capt)) state)
(cons (cons p expr) state)))))) (cons (cons p expr) state))))))
((procedure? p) ((procedure? p)
(and (p expr) state)) (and (p expr) state))
((pair? p) ((pair? p)
(cond ((eq (car p) '-/) (and (equal? (cadr p) expr) state)) (cond ((eq (car p) '-/) (and (equal? (cadr p) expr) state))
((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state)) ((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state))
((eq (car p) '--) ((eq (car p) '--)
(and (match- (caddr p) expr state) (and (match- (caddr p) expr state)
(cons (cons (cadr p) expr) state))) (cons (cons (cadr p) expr) state)))
((eq (car p) '-$) ; greedy alternation for toplevel pattern ((eq (car p) '-$) ; greedy alternation for toplevel pattern
(match-alt (cdr p) () (list expr) state #f 1)) (match-alt (cdr p) () (list expr) state #f 1))
(#t (#t
(and (pair? expr) (and (pair? expr)
(equal? (car p) (car expr)) (equal? (car p) (car expr))
(match-seq (cdr p) (cdr expr) state (length (cdr expr))))))) (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
(#t (#t
(and (equal? p expr) state)))) (and (equal? p expr) state))))
; match an alternation ; match an alternation
(define (match-alt alt prest expr state var L) (define (match-alt alt prest expr state var L)
(if (null? alt) #f ; no alternatives left (if (null? alt) #f ; no alternatives left
(let ((subma (match- (car alt) (car expr) state))) (let ((subma (match- (car alt) (car expr) state)))
(or (and subma (or (and subma
(match-seq prest (cdr expr) (match-seq prest (cdr expr)
(if var (if var
(cons (cons var (car expr)) (cons (cons var (car expr))
subma) subma)
subma) subma)
(- L 1))) (- L 1)))
(match-alt (cdr alt) prest expr state var L))))) (match-alt (cdr alt) prest expr state var L)))))
; match generalized kleene star (try consuming min to max) ; match generalized kleene star (try consuming min to max)
(define (match-star- p prest expr state var min max L sofar) (define (match-star- p prest expr state var min max L sofar)
@ -86,7 +86,7 @@
; case 1: only allowed to match 0 subexpressions ; case 1: only allowed to match 0 subexpressions
((= max 0) (match-seq prest expr ((= max 0) (match-seq prest expr
(if var (cons (cons var (reverse sofar)) state) (if var (cons (cons var (reverse sofar)) state)
state) state)
L)) L))
; case 2: must match at least 1 ; case 2: must match at least 1
((> min 0) ((> min 0)
@ -97,37 +97,37 @@
(#t (#t
(or (match-star- p prest expr state var 0 0 L sofar) (or (match-star- p prest expr state var 0 0 L sofar)
(match-star- p prest expr state var 1 max L sofar))))) (match-star- p prest expr state var 1 max L sofar)))))
(define (match-star p prest expr state var min max L) (define (match-star p prest expr state var min max L)
(match-star- p prest expr state var min max L ())) (match-star- p prest expr state var min max L ()))
; match sequences of expressions ; match sequences of expressions
(define (match-seq p expr state L) (define (match-seq p expr state L)
(cond ((not state) #f) (cond ((not state) #f)
((null? p) (if (null? expr) state #f)) ((null? p) (if (null? expr) state #f))
(#t (#t
(let ((subp (car p)) (let ((subp (car p))
(var #f)) (var #f))
(if (and (pair? subp) (if (and (pair? subp)
(eq (car subp) '--)) (eq (car subp) '--))
(begin (set! var (cadr subp)) (begin (set! var (cadr subp))
(set! subp (caddr subp))) (set! subp (caddr subp)))
#f) #f)
(let ((head (if (pair? subp) (car subp) ()))) (let ((head (if (pair? subp) (car subp) ())))
(cond ((eq subp '...) (cond ((eq subp '...)
(match-star '_ (cdr p) expr state var 0 L L)) (match-star '_ (cdr p) expr state var 0 L L))
((eq head '-*) ((eq head '-*)
(match-star (cadr subp) (cdr p) expr state var 0 L L)) (match-star (cadr subp) (cdr p) expr state var 0 L L))
((eq head '-+) ((eq head '-+)
(match-star (cadr subp) (cdr p) expr state var 1 L L)) (match-star (cadr subp) (cdr p) expr state var 1 L L))
((eq head '-?) ((eq head '-?)
(match-star (cadr subp) (cdr p) expr state var 0 1 L)) (match-star (cadr subp) (cdr p) expr state var 0 1 L))
((eq head '-$) ((eq head '-$)
(match-alt (cdr subp) (cdr p) expr state var L)) (match-alt (cdr subp) (cdr p) expr state var L))
(#t (#t
(and (pair? expr) (and (pair? expr)
(match-seq (cdr p) (cdr expr) (match-seq (cdr p) (cdr expr)
(match- (car p) (car expr) state) (match- (car p) (car expr) state)
(- L 1)))))))))) (- L 1))))))))))
(define (match p expr) (match- p expr (list (cons '__ expr)))) (define (match p expr) (match- p expr (list (cons '__ expr))))
@ -136,12 +136,12 @@
(cond ((and (symbol? p) (cond ((and (symbol? p)
(not (member p metasymbols))) (not (member p metasymbols)))
(list p)) (list p))
((pair? p) ((pair? p)
(if (eq (car p) '-/) (if (eq (car p) '-/)
() ()
(unique (apply append (map patargs- (cdr p)))))) (unique (apply append (map patargs- (cdr p))))))
(#t ()))) (#t ())))
(define (patargs p) (define (patargs p)
(cons '__ (patargs- p))) (cons '__ (patargs- p)))
@ -151,14 +151,14 @@
(define (apply-patterns plist expr) (define (apply-patterns plist expr)
(if (null? plist) expr (if (null? plist) expr
(if (procedure? plist) (if (procedure? plist)
(let ((enew (plist expr))) (let ((enew (plist expr)))
(if (not enew) (if (not enew)
expr expr
enew)) enew))
(let ((enew ((car plist) expr))) (let ((enew ((car plist) expr)))
(if (not enew) (if (not enew)
(apply-patterns (cdr plist) expr) (apply-patterns (cdr plist) expr)
enew))))) enew)))))
; top-down fixed-point macroexpansion. this is a typical algorithm, ; top-down fixed-point macroexpansion. this is a typical algorithm,
; but it may leave some structure that matches a pattern unexpanded. ; but it may leave some structure that matches a pattern unexpanded.
@ -173,9 +173,9 @@
(if (not (pair? expr)) (if (not (pair? expr))
expr expr
(let ((enew (apply-patterns plist expr))) (let ((enew (apply-patterns plist expr)))
(if (eq enew expr) (if (eq enew expr)
; expr didn't change; move to subexpressions ; expr didn't change; move to subexpressions
(cons (car expr) (cons (car expr)
(map (lambda (subex) (pattern-expand plist subex)) (cdr expr))) (map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
; expr changed; iterate ; expr changed; iterate
(pattern-expand plist enew))))) (pattern-expand plist enew)))))

184
scheme-tests/ast/match.scm
View File

@ -32,44 +32,44 @@
; ;
(define (match- p expr state) (define (match- p expr state)
(cond ((symbol? p) (cond ((symbol? p)
(cond ((eq? p '_) state) (cond ((eq? p '_) state)
(else (else
(let ((capt (assq p state))) (let ((capt (assq p state)))
(if capt (if capt
(and (equal? expr (cdr capt)) state) (and (equal? expr (cdr capt)) state)
(cons (cons p expr) state)))))) (cons (cons p expr) state))))))
((procedure? p) ((procedure? p)
(and (p expr) state)) (and (p expr) state))
((pair? p) ((pair? p)
(cond ((eq? (car p) '-/) (and (equal? (cadr p) expr) state)) (cond ((eq? (car p) '-/) (and (equal? (cadr p) expr) state))
((eq? (car p) '-^) (and (not (match- (cadr p) expr state)) state)) ((eq? (car p) '-^) (and (not (match- (cadr p) expr state)) state))
((eq? (car p) '--) ((eq? (car p) '--)
(and (match- (caddr p) expr state) (and (match- (caddr p) expr state)
(cons (cons (cadr p) expr) state))) (cons (cons (cadr p) expr) state)))
((eq? (car p) '-$) ; greedy alternation for toplevel pattern ((eq? (car p) '-$) ; greedy alternation for toplevel pattern
(match-alt (cdr p) () (list expr) state #f 1)) (match-alt (cdr p) () (list expr) state #f 1))
(else (else
(and (pair? expr) (and (pair? expr)
(equal? (car p) (car expr)) (equal? (car p) (car expr))
(match-seq (cdr p) (cdr expr) state (length (cdr expr))))))) (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
(else (else
(and (equal? p expr) state)))) (and (equal? p expr) state))))
; match an alternation ; match an alternation
(define (match-alt alt prest expr state var L) (define (match-alt alt prest expr state var L)
(if (null? alt) #f ; no alternatives left (if (null? alt) #f ; no alternatives left
(let ((subma (match- (car alt) (car expr) state))) (let ((subma (match- (car alt) (car expr) state)))
(or (and subma (or (and subma
(match-seq prest (cdr expr) (match-seq prest (cdr expr)
(if var (if var
(cons (cons var (car expr)) (cons (cons var (car expr))
subma) subma)
subma) subma)
(- L 1))) (- L 1)))
(match-alt (cdr alt) prest expr state var L))))) (match-alt (cdr alt) prest expr state var L)))))
; match generalized kleene star (try consuming min to max) ; match generalized kleene star (try consuming min to max)
(define (match-star p prest expr state var min max L) (define (match-star p prest expr state var min max L)
@ -78,49 +78,49 @@
((> min max) #f) ((> min max) #f)
; case 1: only allowed to match 0 subexpressions ; case 1: only allowed to match 0 subexpressions
((= max 0) (match-seq prest expr ((= max 0) (match-seq prest expr
(if var (cons (cons var (reverse sofar)) state) (if var (cons (cons var (reverse sofar)) state)
state) state)
L)) L))
; case 2: must match at least 1 ; case 2: must match at least 1
((> min 0) ((> min 0)
(and (match- p (car expr) state) (and (match- p (car expr) state)
(match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1) (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
(cons (car expr) sofar)))) (cons (car expr) sofar))))
; otherwise, must match either 0 or between 1 and max subexpressions ; otherwise, must match either 0 or between 1 and max subexpressions
(else (else
(or (match-star- p prest expr state var 0 0 L sofar) (or (match-star- p prest expr state var 0 0 L sofar)
(match-star- p prest expr state var 1 max L sofar))))) (match-star- p prest expr state var 1 max L sofar)))))
(match-star- p prest expr state var min max L ())) (match-star- p prest expr state var min max L ()))
; match sequences of expressions ; match sequences of expressions
(define (match-seq p expr state L) (define (match-seq p expr state L)
(cond ((not state) #f) (cond ((not state) #f)
((null? p) (if (null? expr) state #f)) ((null? p) (if (null? expr) state #f))
(else (else
(let ((subp (car p)) (let ((subp (car p))
(var #f)) (var #f))
(if (and (pair? subp) (if (and (pair? subp)
(eq? (car subp) '--)) (eq? (car subp) '--))
(begin (set! var (cadr subp)) (begin (set! var (cadr subp))
(set! subp (caddr subp))) (set! subp (caddr subp)))
#f) #f)
(let ((head (if (pair? subp) (car subp) ()))) (let ((head (if (pair? subp) (car subp) ())))
(cond ((eq? subp '...) (cond ((eq? subp '...)
(match-star '_ (cdr p) expr state var 0 L L)) (match-star '_ (cdr p) expr state var 0 L L))
((eq? head '-*) ((eq? head '-*)
(match-star (cadr subp) (cdr p) expr state var 0 L L)) (match-star (cadr subp) (cdr p) expr state var 0 L L))
((eq? head '-+) ((eq? head '-+)
(match-star (cadr subp) (cdr p) expr state var 1 L L)) (match-star (cadr subp) (cdr p) expr state var 1 L L))
((eq? head '-?) ((eq? head '-?)
(match-star (cadr subp) (cdr p) expr state var 0 1 L)) (match-star (cadr subp) (cdr p) expr state var 0 1 L))
((eq? head '-$) ((eq? head '-$)
(match-alt (cdr subp) (cdr p) expr state var L)) (match-alt (cdr subp) (cdr p) expr state var L))
(else (else
(and (pair? expr) (and (pair? expr)
(match-seq (cdr p) (cdr expr) (match-seq (cdr p) (cdr expr)
(match- (car p) (car expr) state) (match- (car p) (car expr) state)
(- L 1)))))))))) (- L 1))))))))))
(define (match p expr) (match- p expr (list (cons '__ expr)))) (define (match p expr) (match- p expr (list (cons '__ expr))))
@ -128,15 +128,15 @@
(define (patargs p) (define (patargs p)
(define (patargs- p) (define (patargs- p)
(cond ((and (symbol? p) (cond ((and (symbol? p)
(not (member p metasymbols))) (not (member p metasymbols)))
(list p)) (list p))
((pair? p) ((pair? p)
(if (eq? (car p) '-/) (if (eq? (car p) '-/)
() ()
(delete-duplicates (apply append (map patargs- (cdr p)))))) (delete-duplicates (apply append (map patargs- (cdr p))))))
(else ()))) (else ())))
(cons '__ (patargs- p))) (cons '__ (patargs- p)))
; try to transform expr using a pattern-lambda from plist ; try to transform expr using a pattern-lambda from plist
@ -144,14 +144,14 @@
(define (apply-patterns plist expr) (define (apply-patterns plist expr)
(if (null? plist) expr (if (null? plist) expr
(if (procedure? plist) (if (procedure? plist)
(let ((enew (plist expr))) (let ((enew (plist expr)))
(if (not enew) (if (not enew)
expr expr
enew)) enew))
(let ((enew ((car plist) expr))) (let ((enew ((car plist) expr)))
(if (not enew) (if (not enew)
(apply-patterns (cdr plist) expr) (apply-patterns (cdr plist) expr)
enew))))) enew)))))
; top-down fixed-point macroexpansion. this is a typical algorithm, ; top-down fixed-point macroexpansion. this is a typical algorithm,
; but it may leave some structure that matches a pattern unexpanded. ; but it may leave some structure that matches a pattern unexpanded.
@ -166,9 +166,9 @@
(if (not (pair? expr)) (if (not (pair? expr))
expr expr
(let ((enew (apply-patterns plist expr))) (let ((enew (apply-patterns plist expr)))
(if (eq? enew expr) (if (eq? enew expr)
; expr didn't change; move to subexpressions ; expr didn't change; move to subexpressions
(cons (car expr) (cons (car expr)
(map (lambda (subex) (pattern-expand plist subex)) (cdr expr))) (map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
; expr changed; iterate ; expr changed; iterate
(pattern-expand plist enew))))) (pattern-expand plist enew)))))

2646
scheme-tests/ast/rpasses-out.scm
View File

File diff suppressed because it is too large Load Diff

60
scheme-tests/ast/rpasses.scm
View File

@ -21,21 +21,23 @@
(let ((ctr 0)) (let ((ctr 0))
(set! r-gensym (lambda () (set! r-gensym (lambda ()
(prog1 (symbol (string "%r:" ctr)) (prog1 (symbol (string "%r:" ctr))
(set! ctr (+ ctr 1)))))) (set! ctr (+ ctr 1))))))
(define (dollarsign-transform e) (define (dollarsign-transform e)
(pattern-expand (pattern-expand
(pattern-lambda ($ lhs name) (pattern-lambda
(let* ((g (if (not (pair? lhs)) lhs (r-gensym))) ($ lhs name)
(n (if (symbol? name) (let* ((g (if (not (pair? lhs)) lhs (r-gensym)))
name ;(symbol->string name) (n (if (symbol? name)
name)) name ;(symbol->string name)
(expr `(r-call name))
r-aref ,g (index-in-strlist ,n (r-call attr ,g "names"))))) (expr `(r-call
(if (not (pair? lhs)) r-aref ,g
expr (index-in-strlist ,n (r-call attr ,g "names")))))
`(r-block (ref= ,g ,lhs) ,expr)))) (if (not (pair? lhs))
expr
`(r-block (ref= ,g ,lhs) ,expr))))
e)) e))
; lower r expressions of the form f(lhs,...) <- rhs ; lower r expressions of the form f(lhs,...) <- rhs
@ -47,10 +49,11 @@
(pattern-expand (pattern-expand
(pattern-lambda (-$ (<- (r-call f lhs ...) rhs) (pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
(<<- (r-call f lhs ...) rhs)) (<<- (r-call f lhs ...) rhs))
(let ((g (if (pair? rhs) (r-gensym) rhs)) (let ((g (if (pair? rhs) (r-gensym) rhs))
(op (car __))) (op (car __)))
`(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ()) `(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ())
(,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g)) (,op ,lhs (r-call ,(symconcat f '<-)
,@(cddr (cadr __)) ,g))
,g))) ,g)))
e)) e))
@ -60,35 +63,36 @@
; added to its body ; added to its body
(define (gen-default-inits arglist) (define (gen-default-inits arglist)
(map (lambda (arg) (map (lambda (arg)
(let ((name (cadr arg)) (let ((name (cadr arg))
(default (caddr arg))) (default (caddr arg)))
`(when (missing ,name) `(when (missing ,name)
(<- ,name ,default)))) (<- ,name ,default))))
(filter (lambda (arg) (not (eq (caddr arg) missing-arg-tag))) arglist))) (filter (lambda (arg) (not (eq (caddr arg) missing-arg-tag)))
arglist)))
; convert r function expressions to lambda ; convert r function expressions to lambda
(define (normalize-r-functions e) (define (normalize-r-functions e)
(maptree-post (lambda (n) (maptree-post (lambda (n)
(if (and (pair? n) (eq (car n) 'function)) (if (and (pair? n) (eq (car n) 'function))
`(lambda ,(func-argnames n) `(lambda ,(func-argnames n)
(r-block ,@(gen-default-inits (cadr n)) (r-block ,@(gen-default-inits (cadr n))
,@(if (and (pair? (caddr n)) ,@(if (and (pair? (caddr n))
(eq (car (caddr n)) 'r-block)) (eq (car (caddr n)) 'r-block))
(cdr (caddr n)) (cdr (caddr n))
(list (caddr n))))) (list (caddr n)))))
n)) n))
e)) e))
(define (find-assigned-vars n) (define (find-assigned-vars n)
(let ((vars ())) (let ((vars ()))
(maptree-pre (lambda (s) (maptree-pre (lambda (s)
(if (not (pair? s)) s (if (not (pair? s)) s
(cond ((eq (car s) 'lambda) ()) (cond ((eq (car s) 'lambda) ())
((eq (car s) '<-) ((eq (car s) '<-)
(set! vars (list-adjoin (cadr s) vars)) (set! vars (list-adjoin (cadr s) vars))
(cddr s)) (cddr s))
(#t s)))) (#t s))))
n) n)
vars)) vars))
; introduce let based on assignment statements ; introduce let based on assignment statements

10
scheme-tests/color.scm
View File

@ -1,6 +1,6 @@
; -*- scheme -*- ; -*- scheme -*-
; dictionaries ---------------------------------------------------------------- ; dictionaries ---------------------------------------------------------------
(define (dict-new) ()) (define (dict-new) ())
(define (dict-extend dl key value) (define (dict-extend dl key value)
@ -15,7 +15,7 @@
(define (dict-keys dl) (map car dl)) (define (dict-keys dl) (map car dl))
; graphs ---------------------------------------------------------------------- ; graphs ---------------------------------------------------------------------
(define (graph-empty) (dict-new)) (define (graph-empty) (dict-new))
(define (graph-connect g n1 n2) (define (graph-connect g n1 n2)
@ -39,7 +39,7 @@
(caar edge-list) (caar edge-list)
(cdar edge-list)))) (cdar edge-list))))
; graph coloring -------------------------------------------------------------- ; graph coloring -------------------------------------------------------------
(define (node-colorable? g coloring node-to-color color-of-node) (define (node-colorable? g coloring node-to-color color-of-node)
(not (member (not (member
color-of-node color-of-node
@ -52,7 +52,7 @@
(define (try-each f lst) (define (try-each f lst)
(if (null? lst) #f (if (null? lst) #f
(let ((ret (f (car lst)))) (let ((ret (f (car lst))))
(if ret ret (try-each f (cdr lst)))))) (if ret ret (try-each f (cdr lst))))))
(define (color-node g coloring colors uncolored-nodes color) (define (color-node g coloring colors uncolored-nodes color)
(cond (cond
@ -72,7 +72,7 @@
(define (color-pairs pairs colors) (define (color-pairs pairs colors)
(color-graph (graph-from-edges pairs) colors)) (color-graph (graph-from-edges pairs) colors))
; queens ---------------------------------------------------------------------- ; queens ---------------------------------------------------------------------
(define (can-attack x y) (define (can-attack x y)
(let ((x1 (mod x 5)) (let ((x1 (mod x 5))
(y1 (truncate (/ x 5))) (y1 (truncate (/ x 5)))

60
scheme-tests/equal.scm
View File

@ -7,14 +7,14 @@
; nontermination, otherwise #t or #f for the correct answer. ; nontermination, otherwise #t or #f for the correct answer.
(define (bounded-equal a b N) (define (bounded-equal a b N)
(cond ((<= N 0) 0) (cond ((<= N 0) 0)
((and (pair? a) (pair? b)) ((and (pair? a) (pair? b))
(let ((as (let ((as
(bounded-equal (car a) (car b) (- N 1)))) (bounded-equal (car a) (car b) (- N 1))))
(if (number? as) (if (number? as)
0 0
(and as (and as
(bounded-equal (cdr a) (cdr b) (- N 1)))))) (bounded-equal (cdr a) (cdr b) (- N 1))))))
(else (eq? a b)))) (else (eq? a b))))
; union-find algorithm ; union-find algorithm
@ -23,8 +23,8 @@
(define (class table key) (define (class table key)
(let ((c (hashtable-ref table key #f))) (let ((c (hashtable-ref table key #f)))
(if (or (not c) (eq? c key)) (if (or (not c) (eq? c key))
c c
(class table c)))) (class table c))))
; move a and b to the same equivalence class, given c and cb ; move a and b to the same equivalence class, given c and cb
; as the current values of (class table a) and (class table b) ; as the current values of (class table a) and (class table b)
@ -34,7 +34,7 @@
(define (union! table a b c cb) (define (union! table a b c cb)
(let ((ca (if c c a))) (let ((ca (if c c a)))
(if cb (if cb
(hashtable-set! table cb ca)) (hashtable-set! table cb ca))
(hashtable-set! table a ca) (hashtable-set! table a ca)
(hashtable-set! table b ca))) (hashtable-set! table b ca)))
@ -43,26 +43,26 @@
; set them equal and move on. ; set them equal and move on.
(define (cyc-equal a b table) (define (cyc-equal a b table)
(cond ((eq? a b) #t) (cond ((eq? a b) #t)
((not (and (pair? a) (pair? b))) (eq? a b)) ((not (and (pair? a) (pair? b))) (eq? a b))
(else (else
(let ((aa (car a)) (da (cdr a)) (let ((aa (car a)) (da (cdr a))
(ab (car b)) (db (cdr b))) (ab (car b)) (db (cdr b)))
(cond ((or (not (eq? (atom? aa) (atom? ab))) (cond ((or (not (eq? (atom? aa) (atom? ab)))
(not (eq? (atom? da) (atom? db)))) #f) (not (eq? (atom? da) (atom? db)))) #f)
((and (atom? aa) ((and (atom? aa)
(not (eq? aa ab))) #f) (not (eq? aa ab))) #f)
((and (atom? da) ((and (atom? da)
(not (eq? da db))) #f) (not (eq? da db))) #f)
(else (else
(let ((ca (class table a)) (let ((ca (class table a))
(cb (class table b))) (cb (class table b)))
(if (and ca cb (eq? ca cb)) (if (and ca cb (eq? ca cb))
#t #t
(begin (union! table a b ca cb) (begin (union! table a b ca cb)
(and (cyc-equal aa ab table) (and (cyc-equal aa ab table)
(cyc-equal da db table))))))))))) (cyc-equal da db table)))))))))))
(define (equal a b) (define (equal a b)
(let ((guess (bounded-equal a b 2048))) (let ((guess (bounded-equal a b 2048)))
(if (boolean? guess) guess (if (boolean? guess) guess
(cyc-equal a b (make-eq-hashtable))))) (cyc-equal a b (make-eq-hashtable)))))

8
scheme-tests/perf.scm
View File

@ -19,10 +19,10 @@
(cond ((null? lsts) ()) (cond ((null? lsts) ())
((null? (cdr lsts)) (car lsts)) ((null? (cdr lsts)) (car lsts))
(else (letrec ((append2 (lambda (l d) (else (letrec ((append2 (lambda (l d)
(if (null? l) d (if (null? l) d
(cons (car l) (cons (car l)
(append2 (cdr l) d)))))) (append2 (cdr l) d))))))
(append2 (car lsts) (apply my-append (cdr lsts))))))) (append2 (car lsts) (apply my-append (cdr lsts)))))))
(princ "append: ") (princ "append: ")
(set! L (map-int (lambda (x) (map-int identity 20)) 20)) (set! L (map-int (lambda (x) (map-int identity 20)) 20))

9
scheme-tests/printcases.scm
View File

@ -14,11 +14,14 @@ bq-process
(list->vector (map-int (lambda (x) `(a b c d e)) 90)) (list->vector (map-int (lambda (x) `(a b c d e)) 90))
'((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y)) '((lambda (x y) (if (< x y) x y))
(a b c) (d e f) 2 3 (r t y))
'((lambda (x y) (if (< x y) x yffffffffffffffffffff)) (a b c) (d e f) 2 3 (r t y)) '((lambda (x y) (if (< x y) x yffffffffffffffffffff))
(a b c) (d e f) 2 3 (r t y))
'((lambda (x y) (if (< x y) x y)) (a b c) (d (e zz zzz) f) 2 3 (r t y)) '((lambda (x y) (if (< x y) x y))
(a b c) (d (e zz zzz) f) 2 3 (r t y))
'((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e) '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
(19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d) (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)

8
scheme-tests/tcolor.scm
View File

@ -10,7 +10,7 @@
(dotimes (n 99) (color-pairs Q '(a b c d e)))) (dotimes (n 99) (color-pairs Q '(a b c d e))))
(time (ct)) (time (ct))
(assert (equal? C (assert (equal? C
'((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e) '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b)
(19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d) (21 . e) (19 . b) (16 . c) (13 . c) (11 . b) (7 . e)
(18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e) (24 . c) (20 . d) (18 . e) (15 . a) (12 . a) (10 . e)
(3 . d) (2 . c) (0 . b) (1 . a)))) (6 . d) (5 . c) (4 . e) (3 . d) (2 . c) (0 . b) (1 . a))))

170
scheme-tests/test.scm
View File

@ -19,10 +19,10 @@
(cond ((null? lsts) ()) (cond ((null? lsts) ())
((null? (cdr lsts)) (car lsts)) ((null? (cdr lsts)) (car lsts))
(#t ((label append2 (lambda (l d) (#t ((label append2 (lambda (l d)
(if (null? l) d (if (null? l) d
(cons (car l) (cons (car l)
(append2 (cdr l) d))))) (append2 (cdr l) d)))))
(car lsts) (append-h (cdr lsts))))))) (car lsts) (append-h (cdr lsts)))))))
lsts)) lsts))
;(princ 'Hello '| | 'world! "\n") ;(princ 'Hello '| | 'world! "\n")
@ -49,13 +49,13 @@
(if (<= n 0) (if (<= n 0)
() ()
(let ((first (cons (f 0) ()))) (let ((first (cons (f 0) ())))
((label map-int- ((label map-int-
(lambda (acc i n) (lambda (acc i n)
(if (= i n) (if (= i n)
first first
(begin (set-cdr! acc (cons (f i) ())) (begin (set-cdr! acc (cons (f i) ()))
(map-int- (cdr acc) (+ i 1) n))))) (map-int- (cdr acc) (+ i 1) n)))))
first 1 n)))) first 1 n))))
|# |#
(define-macro (labl name fn) (define-macro (labl name fn)
@ -91,7 +91,7 @@
((label mapl- ((label mapl-
(lambda (lsts) (lambda (lsts)
(if (null? (car lsts)) () (if (null? (car lsts)) ()
(begin (apply f lsts) (mapl- (map cdr lsts)))))) (begin (apply f lsts) (mapl- (map cdr lsts))))))
lsts)) lsts))
; test to see if a symbol begins with : ; test to see if a symbol begins with :
@ -102,7 +102,7 @@
(define (swapad c) (define (swapad c)
(if (atom? c) c (if (atom? c) c
(set-cdr! c (K (swapad (car c)) (set-cdr! c (K (swapad (car c))
(set-car! c (swapad (cdr c))))))) (set-car! c (swapad (cdr c)))))))
(define (without x l) (define (without x l)
(filter (lambda (e) (not (eq e x))) l)) (filter (lambda (e) (not (eq e x))) l))
@ -120,14 +120,14 @@
;[` _ ,_ |- | . _ 2 ;[` _ ,_ |- | . _ 2
;| (/_||||_()|_|_\|) ;| (/_||||_()|_|_\|)
; | ; |
(define-macro (while- test . forms) (define-macro (while- test . forms)
`((label -loop- (lambda () `((label -loop- (lambda ()
(if ,test (if ,test
(begin ,@forms (begin ,@forms
(-loop-)) (-loop-))
()))))) ())))))
; this would be a cool use of thunking to handle 'finally' clauses, but ; this would be a cool use of thunking to handle 'finally' clauses, but
; this code doesn't work in the case where the user manually re-raises ; this code doesn't work in the case where the user manually re-raises
@ -183,22 +183,22 @@
(let ((acc (gensym))) (let ((acc (gensym)))
`(let ((,acc (list ()))) `(let ((,acc (list ())))
(cdr (cdr
(prog1 ,acc (prog1 ,acc
(while ,cnd (while ,cnd
(begin (set! ,acc (begin (set! ,acc
(cdr (set-cdr! ,acc (cons ,what ())))) (cdr (set-cdr! ,acc (cons ,what ()))))
,@body))))))) ,@body)))))))
(define-macro (accumulate-for var lo hi what . body) (define-macro (accumulate-for var lo hi what . body)
(let ((acc (gensym))) (let ((acc (gensym)))
`(let ((,acc (list ()))) `(let ((,acc (list ())))
(cdr (cdr
(prog1 ,acc (prog1 ,acc
(for ,lo ,hi (for ,lo ,hi
(lambda (,var) (lambda (,var)
(begin (set! ,acc (begin (set! ,acc
(cdr (set-cdr! ,acc (cons ,what ())))) (cdr (set-cdr! ,acc (cons ,what ()))))
,@body)))))))) ,@body))))))))
(define (map-indexed f lst) (define (map-indexed f lst)
(if (atom? lst) lst (if (atom? lst) lst
@ -211,84 +211,84 @@
(define (sub h n offs lst) (define (sub h n offs lst)
(let ((i (string.find h n offs))) (let ((i (string.find h n offs)))
(if i (if i
(sub h n (string.inc h i) (cons i lst)) (sub h n (string.inc h i) (cons i lst))
(reverse! lst)))) (reverse! lst))))
(sub haystack needle (if (null? offs) 0 (car offs)) ())) (sub haystack needle (if (null? offs) 0 (car offs)) ()))
(let ((*profiles* (table))) (let ((*profiles* (table)))
(set! profile (set! profile
(lambda (s) (lambda (s)
(let ((f (top-level-value s))) (let ((f (top-level-value s)))
(put! *profiles* s (cons 0 0)) (put! *profiles* s (cons 0 0))
(set-top-level-value! s (set-top-level-value! s
(lambda args (lambda args
(define tt (get *profiles* s)) (define tt (get *profiles* s))
(define count (car tt)) (define count (car tt))
(define time (cdr tt)) (define time (cdr tt))
(define t0 (time.now)) (define t0 (time.now))
(define v (apply f args)) (define v (apply f args))
(set-cdr! tt (+ time (- (time.now) t0))) (set-cdr! tt (+ time (- (time.now) t0)))
(set-car! tt (+ count 1)) (set-car! tt (+ count 1))
v))))) v)))))
(set! show-profiles (set! show-profiles
(lambda () (lambda ()
(define pr (filter (lambda (x) (> (cadr x) 0)) (define pr (filter (lambda (x) (> (cadr x) 0))
(table.pairs *profiles*))) (table.pairs *profiles*)))
(define width (+ 4 (define width (+ 4
(apply max (apply max
(map (lambda (x) (map (lambda (x)
(length (string x))) (length (string x)))
(cons 'Function (cons 'Function
(map car pr)))))) (map car pr))))))
(princ (string.rpad "Function" width #\ ) (princ (string.rpad "Function" width #\ )
"#Calls Time (seconds)") "#Calls Time (seconds)")
(newline) (newline)
(princ (string.rpad "--------" width #\ ) (princ (string.rpad "--------" width #\ )
"------ --------------") "------ --------------")
(newline) (newline)
(for-each (for-each
(lambda (p) (lambda (p)
(princ (string.rpad (string (caddr p)) width #\ ) (princ (string.rpad (string (caddr p)) width #\ )
(string.rpad (string (cadr p)) 11 #\ ) (string.rpad (string (cadr p)) 11 #\ )
(car p)) (car p))
(newline)) (newline))
(simple-sort (map (lambda (l) (reverse (to-proper l))) (simple-sort (map (lambda (l) (reverse (to-proper l)))
pr))))) pr)))))
(set! clear-profiles (set! clear-profiles
(lambda () (lambda ()
(for-each (lambda (k) (for-each (lambda (k)
(put! *profiles* k (cons 0 0))) (put! *profiles* k (cons 0 0)))
(table.keys *profiles*))))) (table.keys *profiles*)))))
#;(for-each profile #;(for-each profile
'(emit encode-byte-code const-to-idx-vec '(emit encode-byte-code const-to-idx-vec
index-of lookup-sym in-env? any every index-of lookup-sym in-env? any every
compile-sym compile-if compile-begin compile-sym compile-if compile-begin
compile-arglist expand builtin->instruction compile-arglist expand builtin->instruction
compile-app separate nconc get-defined-vars compile-app separate nconc get-defined-vars
compile-in compile compile-f delete-duplicates compile-in compile compile-f delete-duplicates
map length> length= count filter append map length> length= count filter append
lastcdr to-proper reverse reverse! list->vector lastcdr to-proper reverse reverse! list->vector
table.foreach list-head list-tail assq memq assoc member table.foreach list-head list-tail assq memq assoc member
assv memv nreconc bq-process)) assv memv nreconc bq-process))
(define (filt1 pred lst) (define (filt1 pred lst)
(define (filt1- pred lst accum) (define (filt1- pred lst accum)
(if (null? lst) accum (if (null? lst) accum
(if (pred (car lst)) (if (pred (car lst))
(filt1- pred (cdr lst) (cons (car lst) accum)) (filt1- pred (cdr lst) (cons (car lst) accum))
(filt1- pred (cdr lst) accum)))) (filt1- pred (cdr lst) accum))))
(filt1- pred lst ())) (filt1- pred lst ()))
(define (filto pred lst (accum ())) (define (filto pred lst (accum ()))
(if (atom? lst) accum (if (atom? lst) accum
(if (pred (car lst)) (if (pred (car lst))
(filto pred (cdr lst) (cons (car lst) accum)) (filto pred (cdr lst) (cons (car lst) accum))
(filto pred (cdr lst) accum)))) (filto pred (cdr lst) accum))))
; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d)) ; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d))
(define (pairwise? pred . args) (define (pairwise? pred . args)
(or (null? args) (or (null? args)
(let f ((a (car args)) (d (cdr args))) (let f ((a (car args)) (d (cdr args)))
(or (null? d) (or (null? d)
(and (pred a (car d)) (f (car d) (cdr d))))))) (and (pred a (car d)) (f (car d) (cdr d)))))))

6
scheme-tests/torture.scm
View File

@ -19,6 +19,6 @@
(define (f x) (define (f x)
(begin (write x) (begin (write x)
(newline) (newline)
(f (+ x 1)) (f (+ x 1))
0)) 0))

97
scheme-tests/unittest.scm
View File

@ -1,11 +1,14 @@
; -*- scheme -*- ; -*- scheme -*-
(define-macro (assert-fail expr . what) (define-macro (assert-fail expr . what)
`(assert (trycatch (begin ,expr #f) `(assert (trycatch (begin ,expr #f)
(lambda (e) ,(if (null? what) #t (lambda (e) ,(if (null? what) #t
`(eq? (car e) ',(car what))))))) `(eq? (car e) ',(car what)))))))
(define (every-int n) (define (every-int n)
(list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n) (list (fixnum n)
(int8 n) (uint8 n)
(int16 n) (uint16 n)
(int32 n) (uint32 n)
(int64 n) (uint64 n))) (int64 n) (uint64 n)))
(define (every-sint n) (define (every-sint n)
@ -14,7 +17,7 @@
(define (each f l) (define (each f l)
(if (atom? l) () (if (atom? l) ()
(begin (f (car l)) (begin (f (car l))
(each f (cdr l))))) (each f (cdr l)))))
(define (each^2 f l m) (define (each^2 f l m)
(each (lambda (o) (each (lambda (p) (f o p)) m)) l)) (each (lambda (o) (each (lambda (p) (f o p)) m)) l))
@ -71,9 +74,9 @@
(assert (not (equal? #int64(0x8000000000000000) #uint64(0x8000000000000000)))) (assert (not (equal? #int64(0x8000000000000000) #uint64(0x8000000000000000))))
(assert (equal? (+ #int64(0x4000000000000000) #int64(0x4000000000000000)) (assert (equal? (+ #int64(0x4000000000000000) #int64(0x4000000000000000))
#uint64(0x8000000000000000))) #uint64(0x8000000000000000)))
(assert (equal? (* 2 #int64(0x4000000000000000)) (assert (equal? (* 2 #int64(0x4000000000000000))
#uint64(0x8000000000000000))) #uint64(0x8000000000000000)))
(assert (equal? (uint64 (double -123)) #uint64(0xffffffffffffff85))) (assert (equal? (uint64 (double -123)) #uint64(0xffffffffffffff85)))
@ -128,9 +131,9 @@
(assert (= (apply + (iota 100000)) 4999950000)) (assert (= (apply + (iota 100000)) 4999950000))
(define ones (map (lambda (x) 1) (iota 80000))) (define ones (map (lambda (x) 1) (iota 80000)))
(assert (= (eval `(if (< 2 1) (assert (= (eval `(if (< 2 1)
(+ ,@ones) (+ ,@ones)
(+ ,@(cdr ones)))) (+ ,@(cdr ones))))
79999)) 79999))
(define MAX_ARGS 255) (define MAX_ARGS 255)
@ -142,10 +145,10 @@
(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 100)))) (define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 100))))
(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42) (define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
,(car (last-pair as))))) ,(car (last-pair as)))))
(assert (equal? (apply ff (iota (+ MAX_ARGS 100))) 42)) (assert (equal? (apply ff (iota (+ MAX_ARGS 100))) 42))
(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42) (define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
(lambda () ,(car (last-pair as)))))) (lambda () ,(car (last-pair as))))))
(assert (equal? ((apply ff (iota (+ MAX_ARGS 100)))) 42)) (assert (equal? ((apply ff (iota (+ MAX_ARGS 100)))) 42))
(define as (map-int (lambda (x) (gensym)) 1000)) (define as (map-int (lambda (x) (gensym)) 1000))
@ -173,9 +176,9 @@
(assert (not (keyword? 'kw))) (assert (not (keyword? 'kw)))
(assert (not (keyword? ':))) (assert (not (keyword? ':)))
(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 1 0 8 4 5) (assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 1 0 8 4 5)
'(1 0 0 (8 4 5)))) '(1 0 0 (8 4 5))))
(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 0 b: 3 1) (assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 0 b: 3 1)
'(0 2 3 (1)))) '(0 2 3 (1))))
(define (keys4 (a: 8) (b: 3) (c: 7) (d: 6)) (list a b c d)) (define (keys4 (a: 8) (b: 3) (c: 7) (d: 6)) (list a b c d))
(assert (equal? (keys4 a: 10) '(10 3 7 6))) (assert (equal? (keys4 a: 10) '(10 3 7 6)))
(assert (equal? (keys4 b: 10) '(8 10 7 6))) (assert (equal? (keys4 b: 10) '(8 10 7 6)))
@ -214,75 +217,75 @@
(load "color.scm") (load "color.scm")
(assert (equal? (color-pairs (generate-5x5-pairs) '(a b c d e)) (assert (equal? (color-pairs (generate-5x5-pairs) '(a b c d e))
'((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e) '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b)
(19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d) (21 . e) (19 . b) (16 . c) (13 . c) (11 . b) (7 . e)
(18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e) (24 . c) (20 . d) (18 . e) (15 . a) (12 . a) (10 . e)
(3 . d) (2 . c) (0 . b) (1 . a)))) (6 . d) (5 . c) (4 . e) (3 . d) (2 . c) (0 . b) (1 . a))))
; hashing strange things ; hashing strange things
(assert (equal? (assert (equal?
(hash '#0=(1 1 #0# . #0#)) (hash '#0=(1 1 #0# . #0#))
(hash '#1=(1 1 #1# 1 1 #1# . #1#)))) (hash '#1=(1 1 #1# 1 1 #1# . #1#))))
(assert (not (equal? (assert (not (equal?
(hash '#0=(1 1 #0# . #0#)) (hash '#0=(1 1 #0# . #0#))
(hash '#1=(1 2 #1# 1 1 #1# . #1#))))) (hash '#1=(1 2 #1# 1 1 #1# . #1#)))))
(assert (equal? (assert (equal?
(hash '#0=((1 . #0#) . #0#)) (hash '#0=((1 . #0#) . #0#))
(hash '#1=((1 . #1#) (1 . #1#) . #1#)))) (hash '#1=((1 . #1#) (1 . #1#) . #1#))))
(assert (not (equal? (assert (not (equal?
(hash '#0=((1 . #0#) . #0#)) (hash '#0=((1 . #0#) . #0#))
(hash '#1=((2 . #1#) (1 . #1#) . #1#))))) (hash '#1=((2 . #1#) (1 . #1#) . #1#)))))
(assert (not (equal? (assert (not (equal?
(hash '#0=((1 . #0#) . #0#)) (hash '#0=((1 . #0#) . #0#))
(hash '#1=((1 . #1#) (2 . #1#) . #1#))))) (hash '#1=((1 . #1#) (2 . #1#) . #1#)))))
(assert (equal? (assert (equal?
(hash '(#0=(#0#) 0)) (hash '(#0=(#0#) 0))
(hash '(#1=(((((#1#))))) 0)))) (hash '(#1=(((((#1#))))) 0))))
(assert (not (equal? (assert (not (equal?
(hash '(#0=(#0#) 0)) (hash '(#0=(#0#) 0))
(hash '(#1=(((((#1#))))) 1))))) (hash '(#1=(((((#1#))))) 1)))))
(assert (equal? (assert (equal?
(hash #0=[1 [2 [#0#]] 3]) (hash #0=[1 [2 [#0#]] 3])
(hash #1=[1 [2 [[1 [2 [#1#]] 3]]] 3]))) (hash #1=[1 [2 [[1 [2 [#1#]] 3]]] 3])))
(assert (not (equal? (assert (not (equal?
(hash #0=[1 [2 [#0#]] 3]) (hash #0=[1 [2 [#0#]] 3])
(hash #1=[1 [2 [[5 [2 [#1#]] 3]]] 3])))) (hash #1=[1 [2 [[5 [2 [#1#]] 3]]] 3]))))
(assert (equal? (assert (equal?
(hash #0=[1 #0# [2 [#0#]] 3]) (hash #0=[1 #0# [2 [#0#]] 3])
(hash #1=[1 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3]))) (hash #1=[1 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3])))
(assert (not (equal? (assert (not (equal?
(hash #0=[1 #0# [2 [#0#]] 3]) (hash #0=[1 #0# [2 [#0#]] 3])
(hash #1=[6 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3])))) (hash #1=[6 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3]))))
(assert (equal? (assert (equal?
(hash [1 [2 [[1 1 [2 [1]] 3]]] 3]) (hash [1 [2 [[1 1 [2 [1]] 3]]] 3])
(hash [1 [2 [[1 1 [2 [1]] 3]]] 3]))) (hash [1 [2 [[1 1 [2 [1]] 3]]] 3])))
(assert (not (equal? (assert (not (equal?
(hash [6 1 [2 [[3 1 [2 [1]] 3]]] 3]) (hash [6 1 [2 [[3 1 [2 [1]] 3]]] 3])
(hash [6 1 [2 [[1 1 [2 [1]] 3]]] 3])))) (hash [6 1 [2 [[1 1 [2 [1]] 3]]] 3]))))
(assert (equal? (hash '#0=(1 . #0#)) (assert (equal? (hash '#0=(1 . #0#))
(hash '#1=(1 1 . #1#)))) (hash '#1=(1 1 . #1#))))
(assert (not (equal? (hash '#0=(1 1 . #0#)) (assert (not (equal? (hash '#0=(1 1 . #0#))
(hash '#1=(1 #0# . #1#))))) (hash '#1=(1 #0# . #1#)))))
(assert (not (equal? (hash (iota 10)) (assert (not (equal? (hash (iota 10))
(hash (iota 20))))) (hash (iota 20)))))
(assert (not (equal? (hash (iota 41)) (assert (not (equal? (hash (iota 41))
(hash (iota 42))))) (hash (iota 42)))))
(if (top-level-bound? 'time.fromstring) (if (top-level-bound? 'time.fromstring)
(assert (let ((ts (time.string (time.now)))) (assert (let ((ts (time.string (time.now))))

2
scheme-tests/wt.scm
View File

@ -14,7 +14,7 @@
(if (< i 10000000) (if (< i 10000000)
(begin (set! i (+ i 1)) (begin (set! i (+ i 1))
(loop)) (loop))
())))) ()))))
(loop))) (loop)))
#| #|

3
scripts/build.sh
View File

@ -1,7 +1,8 @@
#!/bin/sh #!/bin/sh
set -eu set -eu
CC="${CC:-clang}" CC="${CC:-clang}"
CFLAGS="-O2 -falign-functions -Wall -Wno-strict-aliasing -I ../c -D NDEBUG -D USE_COMPUTED_GOTO" CFLAGS="-O2 -falign-functions -Wall -Wno-strict-aliasing"
CFLAGS="$CFLAGS -I ../c -D NDEBUG -D USE_COMPUTED_GOTO"
LFLAGS="-lm" LFLAGS="-lm"
builddir="build-$(uname | tr A-Z- a-z_)-$(uname -m | tr A-Z- a-z_)" builddir="build-$(uname | tr A-Z- a-z_)-$(uname -m | tr A-Z- a-z_)"
cd "$(dirname "$0")"/.. cd "$(dirname "$0")"/..