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

74
c/lookup3.c
View File

@ -1,5 +1,5 @@
/*
-------------------------------------------------------------------------------
------------------------------------------------------------------------------
lookup3.c, by Bob Jenkins, May 2006, Public Domain.
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
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.
-------------------------------------------------------------------------------
------------------------------------------------------------------------------
*/
//#define SELF_TEST 1
@ -74,7 +74,7 @@ typedef unsigned short uint16_t;
#define rot(x, k) (((x) << (k)) | ((x) >> (32 - (k))))
/*
-------------------------------------------------------------------------------
------------------------------------------------------------------------------
mix -- mix 3 32-bit values reversibly.
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
on, and rotates are much kinder to the top and bottom bits, so I used
rotates.
-------------------------------------------------------------------------------
------------------------------------------------------------------------------
*/
#define mix(a, b, c) \
{ \
@ -140,7 +140,7 @@ rotates.
}
/*
-------------------------------------------------------------------------------
------------------------------------------------------------------------------
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
@ -162,7 +162,7 @@ and these came close:
4 8 15 26 3 22 24
10 8 15 26 3 22 24
11 8 15 26 3 22 24
-------------------------------------------------------------------------------
------------------------------------------------------------------------------
*/
#define final(a, b, c) \
{ \
@ -183,7 +183,7 @@ and these came close:
}
/*
--------------------------------------------------------------------
------------------------------------------------------------------------------
This works on all machines. To be useful, it requires
-- that the key be an array of uint32_t's, and
-- 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
bytes. hashlittle() is more complicated than hashword() only because
hashlittle() has to dance around fitting the key bytes into registers.
--------------------------------------------------------------------
------------------------------------------------------------------------------
*/
uint32_t
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
/*
-------------------------------------------------------------------------------
------------------------------------------------------------------------------
hashlittle() -- hash a variable-length key into a 32-bit value
k : the key (the unaligned variable-length array of 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
acceptable. Do NOT use for cryptographic purposes.
-------------------------------------------------------------------------------
------------------------------------------------------------------------------
*/
uint32_t hashlittle( const void *key, size_t length, uint32_t initval)
{
uint32_t a,b,c; /* internal state */
union { const void *ptr; size_t i; } u; /* needed for Mac Powerbook G4 */
uint32_t a,b,c; /* internal state */
union { const void *ptr; size_t i; } u; /* needed for Mac Powerbook G4 */
/* Set up the internal state */
a = b = c = 0xdeadbeef + ((uint32_t)length) + initval;
u.ptr = key;
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;
/*------ 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)
{
a += k[0];
@ -337,8 +337,8 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval)
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
* 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
@ -363,7 +363,7 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval)
case 3 : a+=k[0]&0xffffff; break;
case 2 : a+=k[0]&0xffff; 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 */
@ -389,10 +389,10 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval)
#endif /* !valgrind */
} 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;
/*--------------- all but last block: aligned reads and different mixing */
/*-------------- all but last block: aligned reads and different mixing */
while (length > 12)
{
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;
}
/*----------------------------- handle the last (probably partial) block */
/*---------------------------- handle the last (probably partial) block */
k8 = (const uint8_t *)k;
switch(length)
{
@ -432,13 +432,13 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval)
break;
case 1 : a+=k8[0];
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;
/*--------------- 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)
{
a += k[0];
@ -458,8 +458,8 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval)
k += 12;
}
/*-------------------------------- last block: affect all 32 bits of (c) */
switch(length) /* all the case statements fall through */
/*------------------------------- last block: affect all 32 bits of (c) */
switch(length) /* all the case statements fall through */
{
case 12: c+=((uint32_t)k[11])<<24;
case 11: c+=((uint32_t)k[10])<<16;
@ -767,22 +767,22 @@ uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */
* hashbig():
* This is the same as hashword() on big-endian machines. It is different
* 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 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 */
a = b = c = 0xdeadbeef + ((uint32_t)length) + initval;
u.ptr = key;
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;
/*------ 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)
{
a += k[0];
@ -793,8 +793,8 @@ uint32_t hashbig( const void *key, size_t length, uint32_t initval)
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
* 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
@ -819,13 +819,13 @@ uint32_t hashbig( const void *key, size_t length, uint32_t initval)
case 3 : a+=k[0]&0xffffff00; break;
case 2 : a+=k[0]&0xffff0000; 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 */
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 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 */
} 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;
/*--------------- 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)
{
a += ((uint32_t)k[0])<<24;
@ -867,8 +867,8 @@ uint32_t hashbig( const void *key, size_t length, uint32_t initval)
k += 12;
}
/*-------------------------------- last block: affect all 32 bits of (c) */
switch(length) /* all the case statements fall through */
/*------------------------------- last block: affect all 32 bits of (c) */
switch(length) /* all the case statements fall through */
{
case 12: c+=k[11];
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 */
double genrand_real1(void)
{
return genrand_int32()*(1.0/4294967295.0);
/* divided by 2^32-1 */
return genrand_int32()*(1.0/4294967295.0);
/* divided by 2^32-1 */
}
/* generates a random number on [0,1)-real-interval */
double genrand_real2(void)
{
return genrand_int32()*(1.0/4294967296.0);
return genrand_int32()*(1.0/4294967296.0);
/* divided by 2^32 */
}
/* generates a random number on (0,1)-real-interval */
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 */
}
/* generates a random number on [0,1) with 53-bit resolution*/
double genrand_res53(void)
{
uint32_t a=genrand_int32()>>5, b=genrand_int32()>>6;
return(a*67108864.0+b)*(1.0/9007199254740992.0);
double genrand_res53(void)
{
uint32_t a=genrand_int32()>>5, b=genrand_int32()>>6;
return(a*67108864.0+b)*(1.0/9007199254740992.0);
}
#endif
/* 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)
{
#if __CPU__ > 386
__asm("bswap %0"
__asm("bswap %0"
: "=r"(x)
:
#else
__asm("xchgb %b0,%h0\n"
" rorl $16,%0\n"
" xchgb %b0,%h0"
__asm("xchgb %b0,%h0\n"
" rorl $16,%0\n"
" xchgb %b0,%h0"
: LEGACY_REGS(x)
:
#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)
{
#ifdef ARCH_X86_64
__asm("bswap %0" : "=r"(x) : "0"(x));
__asm("bswap %0" : "=r"(x) : "0"(x));
return x;
#else
register union {
__extension__ u_int64_t __ll;
u_int32_t __l[2];
} __x;
asm("xchgl %0,%1"
asm("xchgl %0,%1"
: "=r"(__x.__l[0]), "=r"(__x.__l[1])
: "0"(bswap_32((unsigned long)x)),
"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|}<;" [])
#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
lambda if and pair? eq car quote thrown-value cadr caddr raise])
#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("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [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 (eval x)
((compile-thunk (expand
(if (and (pair? x)
(equal? (car x) "noexpand"))
(cadr x)
x)))))
(if (and (pair? x)
(equal? (car x) "noexpand"))
(cadr x)
x)))))
(define (command-line) *argv*)
(define gensym
@ -142,21 +142,21 @@
(define get-datum read)
(define (put-datum port x)
(with-bindings ((*print-readably* #t))
(write x port)))
(write x port)))
(define (put-u8 port o) (io.write port (uint8 o)))
(define (put-string port s (start 0) (count #f))
(let* ((start (string.inc s 0 start))
(end (if count
(string.inc s start count)
(sizeof s))))
(end (if count
(string.inc s start count)
(sizeof s))))
(io.write port s start (- end start))))
(define (io.skipws s)
(let ((c (io.peekc s)))
(if (and (not (eof-object? c)) (char-whitespace? c))
(begin (io.getc s)
(io.skipws s)))))
(begin (io.getc s)
(io.skipws s)))))
(define (with-output-to-file name thunk)
(let ((f (file name :write :create :truncate)))
@ -173,12 +173,12 @@
(define (call-with-input-file name proc)
(let ((f (open-input-file name)))
(prog1 (proc f)
(io.close f))))
(io.close f))))
(define (call-with-output-file name proc)
(let ((f (open-output-file name)))
(prog1 (proc f)
(io.close f))))
(io.close f))))
(define (file-exists? f) (path.exists? f))
(define (delete-file name) (void)) ; TODO
@ -187,8 +187,8 @@
(with-output-to port (princ x))
#t)
(define assertion-violation
(lambda args
(define assertion-violation
(lambda args
(display 'assertion-violation)
(newline)
(display args)
@ -206,8 +206,8 @@
(define (assp pred lst)
(cond ((atom? lst) #f)
((pred (caar lst)) (car lst))
(else (assp pred (cdr lst)))))
((pred (caar lst)) (car lst))
(else (assp pred (cdr lst)))))
(define (for-all proc l . ls)
(or (null? l)
@ -218,7 +218,7 @@
(define (exists proc l . ls)
(and (not (null? l))
(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 cons* list*)
@ -236,27 +236,27 @@
(define (dynamic-wind before thunk after)
(before)
(unwind-protect (thunk)
(after)))
(after)))
(let ((*properties* (table)))
(set! putprop
(lambda (sym key val)
(let ((sp (get *properties* sym #f)))
(if (not sp)
(let ((t (table)))
(put! *properties* sym t)
(set! sp t)))
(put! sp key val))))
(lambda (sym key val)
(let ((sp (get *properties* sym #f)))
(if (not sp)
(let ((t (table)))
(put! *properties* sym t)
(set! sp t)))
(put! sp key val))))
(set! getprop
(lambda (sym key)
(let ((sp (get *properties* sym #f)))
(and sp (get sp key #f)))))
(lambda (sym key)
(let ((sp (get *properties* sym #f)))
(and sp (get sp key #f)))))
(set! remprop
(lambda (sym key)
(let ((sp (get *properties* sym #f)))
(and sp (has? sp key) (del! sp key))))))
(lambda (sym key)
(let ((sp (get *properties* sym #f)))
(and sp (has? sp key) (del! sp key))))))
; --- gambit
@ -269,7 +269,7 @@
(define (include f) (load f))
(define (with-exception-catcher hand thk)
(trycatch (thk)
(lambda (e) (hand e))))
(lambda (e) (hand e))))
(define (current-exception-handler)
; 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 next ((E (read in)))
(if (not (io.eof? in))
(begin (print (compile-thunk (expand E)))
(princ "\n")
(next (read in)))))
(begin (print (compile-thunk (expand E)))
(princ "\n")
(next (read in)))))
(io.close in)))
(for-each (lambda (file)
(compile-file file))
(cdr *argv*))
(compile-file file))
(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 (splice-form? x)
(or (and (pair? x) (or (eq? (car x) 'unquote-splicing)
(eq? (car x) 'unquote-nsplicing)
(and (eq? (car x) 'unquote)
(length> x 2))))
(eq? x 'unquote)))
(eq? (car x) 'unquote-nsplicing)
(and (eq? (car x) 'unquote)
(length> x 2))))
(eq? x 'unquote)))
;; bracket without splicing
(define (bq-bracket1 x)
(if (and (pair? x) (eq? (car x) 'unquote))
(if (= d 0)
(cadr x)
(list cons ''unquote
(bq-process2 (cdr x) (- d 1))))
(bq-process2 x d)))
(if (= d 0)
(cadr x)
(list cons ''unquote
(bq-process2 (cdr x) (- d 1))))
(bq-process2 x d)))
(define (bq-bracket x)
(cond ((atom? x) (list list (bq-process2 x d)))
((eq? (car x) 'unquote)
(if (= d 0)
(cons list (cdr x))
(list list (list cons ''unquote
(bq-process2 (cdr x) (- d 1))))))
((eq? (car x) 'unquote-splicing)
(if (= d 0)
(list 'copy-list (cadr x))
(list list (list list ''unquote-splicing
(bq-process2 (cadr x) (- d 1))))))
((eq? (car x) 'unquote-nsplicing)
(if (= d 0)
(cadr x)
(list list (list list ''unquote-nsplicing
(bq-process2 (cadr x) (- d 1))))))
(else (list list (bq-process2 x d)))))
((eq? (car x) 'unquote)
(if (= d 0)
(cons list (cdr x))
(list list (list cons ''unquote
(bq-process2 (cdr x) (- d 1))))))
((eq? (car x) 'unquote-splicing)
(if (= d 0)
(list 'copy-list (cadr x))
(list list (list list ''unquote-splicing
(bq-process2 (cadr x) (- d 1))))))
((eq? (car x) 'unquote-nsplicing)
(if (= d 0)
(cadr x)
(list list (list list ''unquote-nsplicing
(bq-process2 (cadr x) (- d 1))))))
(else (list list (bq-process2 x d)))))
(cond ((symbol? x) (list 'quote x))
((vector? x)
(let ((body (bq-process2 (vector->list x) d)))
(if (eq? (car body) list)
(cons vector (cdr body))
(list apply vector body))))
((vector? x)
(let ((body (bq-process2 (vector->list x) d)))
(if (eq? (car body) list)
(cons vector (cdr body))
(list apply vector body))))
((atom? x) x)
((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)
(if (and (= d 0) (length= x 2))
(cadr x)
(list cons ''unquote (bq-process2 (cdr x) (- d 1)))))
((or (> d 0) (not (any splice-form? x)))
(if (and (= d 0) (length= x 2))
(cadr x)
(list cons ''unquote (bq-process2 (cdr x) (- d 1)))))
((or (> d 0) (not (any splice-form? x)))
(let ((lc (lastcdr x))
(forms (map bq-bracket1 x)))
(if (null? lc)
(cons list forms)
(if (null? (cdr forms))
(list cons (car forms) (bq-process2 lc d))
(nconc (cons list* forms) (list (bq-process2 lc d)))))))
(else
(let loop ((p x) (q ()))
(cond ((null? p) ;; proper list
(cons 'nconc (reverse! q)))
((pair? p)
(cond ((eq? (car p) 'unquote)
;; (... . ,x)
(cons 'nconc
(nreconc q
(if (= d 0)
(cdr p)
(list (list list ''unquote)
(bq-process2 (cdr p)
(- d 1)))))))
(else
(loop (cdr p) (cons (bq-bracket (car p)) q)))))
(else
;; (... . x)
(cons 'nconc (reverse! (cons (bq-process2 p d) q)))))))))
(if (null? (cdr forms))
(list cons (car forms) (bq-process2 lc d))
(nconc (cons list* forms) (list (bq-process2 lc d)))))))
(else
(let loop ((p x) (q ()))
(cond ((null? p) ;; proper list
(cons 'nconc (reverse! q)))
((pair? p)
(cond ((eq? (car p) 'unquote)
;; (... . ,x)
(cons 'nconc
(nreconc q
(if (= d 0)
(cdr p)
(list (list list ''unquote)
(bq-process2 (cdr p)
(- d 1)))))))
(else
(loop (cdr p) (cons (bq-bracket (car p)) q)))))
(else
;; (... . x)
(cons 'nconc (reverse! (cons (bq-process2 p d) q)))))))))
#|
tests
@ -98,25 +98,25 @@ tests
(define (bq-process0 x d)
(define (bq-bracket x)
(cond ((and (pair? x) (eq? (car x) 'unquote))
(if (= d 0)
(cons list (cdr x))
(list list (list cons ''unquote
(bq-process0 (cdr x) (- d 1))))))
((and (pair? x) (eq? (car x) 'unquote-splicing))
(if (= d 0)
(list 'copy-list (cadr x))
(list list (list list ''unquote-splicing
(bq-process0 (cadr x) (- d 1))))))
(else (list list (bq-process0 x d)))))
(if (= d 0)
(cons list (cdr x))
(list list (list cons ''unquote
(bq-process0 (cdr x) (- d 1))))))
((and (pair? x) (eq? (car x) 'unquote-splicing))
(if (= d 0)
(list 'copy-list (cadr x))
(list list (list list ''unquote-splicing
(bq-process0 (cadr x) (- d 1))))))
(else (list list (bq-process0 x d)))))
(cond ((symbol? x) (list 'quote x))
((atom? x) x)
((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)
(if (and (= d 0) (length= x 2))
(cadr x)
(list cons ''unquote (bq-process0 (cdr x) (- d 1)))))
(else
(cons 'nconc (map bq-bracket x)))))
(if (and (= d 0) (length= x 2))
(cadr x)
(list cons ''unquote (bq-process0 (cdr x) (- d 1)))))
(else
(cons 'nconc (map bq-bracket x)))))
#t

13
scheme-examples/cps.scm
View File

@ -3,8 +3,8 @@
(cond ((atom? forms) `(,k ,forms))
((null? (cdr forms)) (cps- (car forms) k))
(#t (let ((_ (gensym))) ; var to bind ignored value
(cps- (car forms) `(lambda (,_)
,(begin->cps (cdr forms) k)))))))
(cps- (car forms) `(lambda (,_)
,(begin->cps (cdr forms) k)))))))
(define-macro (lambda/cc args body)
`(cons 'lambda/cc (lambda ,args ,body)))
@ -24,7 +24,7 @@
`(define (,name f k ,@args)
(if (and (pair? f) (eq (car f) 'lambda/cc))
((cdr f) k ,@args)
(k (f ,@args))))))
(k (f ,@args))))))
(def-funcall/cc-n ())
(def-funcall/cc-n (a0))
(def-funcall/cc-n (a0 a1))
@ -242,8 +242,8 @@
(define-macro (define-generator form . body)
(let ((ko (gensym))
(cur (gensym))
(name (car form))
(args (cdr form)))
(name (car form))
(args (cdr form)))
`(define (,name ,@args)
(let ((,ko #f)
(,cur #f))
@ -284,7 +284,8 @@ todo:
* 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

28
scheme-examples/rule30.scm
View File

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

8
scheme-lib/lazy.scm
View File

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

214
scheme-lib/sort.scm
View File

@ -24,23 +24,23 @@
(define (sorted? seq less? . opt-key)
(define key (if (null? opt-key) identity (car opt-key)))
(cond ((null? seq) #t)
((array? seq)
(let ((dimax (+ -1 (car (array-dimensions seq)))))
(or (<= dimax 1)
(let loop ((idx (+ -1 dimax))
(last (key (array-ref seq dimax))))
(or (negative? idx)
(let ((nxt (key (array-ref seq idx))))
(and (less? nxt last)
(loop (+ -1 idx) nxt))))))))
((null? (cdr seq)) #t)
(else
(let loop ((last (key (car seq)))
(next (cdr seq)))
(or (null? next)
(let ((nxt (key (car next))))
(and (not (less? nxt last))
(loop nxt (cdr next)))))))))
((array? seq)
(let ((dimax (+ -1 (car (array-dimensions seq)))))
(or (<= dimax 1)
(let loop ((idx (+ -1 dimax))
(last (key (array-ref seq dimax))))
(or (negative? idx)
(let ((nxt (key (array-ref seq idx))))
(and (less? nxt last)
(loop (+ -1 idx) nxt))))))))
((null? (cdr seq)) #t)
(else
(let loop ((last (key (car seq)))
(next (cdr seq)))
(or (null? next)
(let ((nxt (key (car next))))
(and (not (less? nxt last))
(loop nxt (cdr next)))))))))
;;; (merge a 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 key (if (null? opt-key) identity (car opt-key)))
(cond ((null? a) b)
((null? b) a)
(else
(let loop ((x (car a)) (kx (key (car a))) (a (cdr a))
(y (car b)) (ky (key (car b))) (b (cdr b)))
;; The loop handles the merging of non-empty lists. It has
;; been written this way to save testing and car/cdring.
(if (less? ky kx)
(if (null? b)
(cons y (cons x a))
(cons y (loop x kx a (car b) (key (car b)) (cdr b))))
;; x <= y
(if (null? a)
(cons x (cons y b))
(cons x (loop (car a) (key (car a)) (cdr a) y ky b))))))))
((null? b) a)
(else
(let loop ((x (car a)) (kx (key (car a))) (a (cdr a))
(y (car b)) (ky (key (car b))) (b (cdr b)))
;; The loop handles the merging of non-empty lists. It has
;; been written this way to save testing and car/cdring.
(if (less? ky kx)
(if (null? b)
(cons y (cons x a))
(cons y (loop x kx a (car b) (key (car b)) (cdr b))))
;; x <= y
(if (null? a)
(cons x (cons y b))
(cons x (loop (car a) (key (car a)) (cdr a) y ky b))))))))
(define (sort:merge! a b less? key)
(define (loop r a kcara b kcarb)
(cond ((less? kcarb kcara)
(set-cdr! r b)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a kcara (cdr b) (key (cadr b)))))
(else ; (car a) <= (car b)
(set-cdr! r a)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) (key (cadr a)) b kcarb)))))
(set-cdr! r b)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a kcara (cdr b) (key (cadr b)))))
(else ; (car a) <= (car b)
(set-cdr! r a)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) (key (cadr a)) b kcarb)))))
(cond ((null? a) b)
((null? b) a)
(else
(let ((kcara (key (car a)))
(kcarb (key (car b))))
(cond
((less? kcarb kcara)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a kcara (cdr b) (key (cadr b))))
b)
(else ; (car a) <= (car b)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) (key (cadr a)) b kcarb))
a))))))
((null? b) a)
(else
(let ((kcara (key (car a)))
(kcarb (key (car b))))
(cond
((less? kcarb kcara)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a kcara (cdr b) (key (cadr b))))
b)
(else ; (car a) <= (car b)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) (key (cadr a)) b kcarb))
a))))))
;;; takes two sorted lists a and b and smashes their cdr fields to form a
;;; single sorted list including the elements of both.
@ -106,39 +106,39 @@
(define keyer (if key car identity))
(define (step n)
(cond ((> n 2) (let* ((j (quotient n 2))
(a (step j))
(k (- n j))
(b (step k)))
(sort:merge! a b less? keyer)))
((= n 2) (let ((x (car seq))
(y (cadr seq))
(p seq))
(set! seq (cddr seq))
(cond ((less? (keyer y) (keyer x))
(set-car! p y)
(set-car! (cdr p) x)))
(set-cdr! (cdr p) '())
p))
((= n 1) (let ((p seq))
(set! seq (cdr seq))
(set-cdr! p '())
p))
(else '())))
(a (step j))
(k (- n j))
(b (step k)))
(sort:merge! a b less? keyer)))
((= n 2) (let ((x (car seq))
(y (cadr seq))
(p seq))
(set! seq (cddr seq))
(cond ((less? (keyer y) (keyer x))
(set-car! p y)
(set-car! (cdr p) x)))
(set-cdr! (cdr p) '())
p))
((= n 1) (let ((p seq))
(set! seq (cdr seq))
(set-cdr! p '())
p))
(else '())))
(define (key-wrap! lst)
(cond ((null? lst))
(else (set-car! lst (cons (key (car lst)) (car lst)))
(key-wrap! (cdr lst)))))
(else (set-car! lst (cons (key (car lst)) (car lst)))
(key-wrap! (cdr lst)))))
(define (key-unwrap! lst)
(cond ((null? lst))
(else (set-car! lst (cdar lst))
(key-unwrap! (cdr lst)))))
(else (set-car! lst (cdar lst))
(key-unwrap! (cdr lst)))))
(cond (key
(key-wrap! seq)
(set! seq (step (length seq)))
(key-unwrap! seq)
seq)
(else
(step (length seq)))))
(key-wrap! seq)
(set! seq (step (length seq)))
(key-unwrap! seq)
seq)
(else
(step (length seq)))))
(define (rank-1-array->list array)
(define dimensions (array-dimensions array))
@ -156,22 +156,22 @@
(define (sort! seq less? . opt-key)
(define key (if (null? opt-key) #f (car opt-key)))
(cond ((array? seq)
(let ((dims (array-dimensions seq)))
(do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
(cdr sorted))
(i 0 (+ i 1)))
((null? sorted) seq)
(array-set! seq (car sorted) i))))
(else ; otherwise, assume it is a list
(let ((ret (sort:sort-list! seq less? key)))
(if (not (eq? ret seq))
(do ((crt ret (cdr crt)))
((eq? (cdr crt) seq)
(set-cdr! crt ret)
(let ((scar (car seq)) (scdr (cdr seq)))
(set-car! seq (car ret)) (set-cdr! seq (cdr ret))
(set-car! ret scar) (set-cdr! ret scdr)))))
seq))))
(let ((dims (array-dimensions seq)))
(do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
(cdr sorted))
(i 0 (+ i 1)))
((null? sorted) seq)
(array-set! seq (car sorted) i))))
(else ; otherwise, assume it is a list
(let ((ret (sort:sort-list! seq less? key)))
(if (not (eq? ret seq))
(do ((crt ret (cdr crt)))
((eq? (cdr crt) seq)
(set-cdr! crt ret)
(let ((scar (car seq)) (scdr (cdr seq)))
(set-car! seq (car ret)) (set-cdr! seq (cdr ret))
(set-car! ret scar) (set-cdr! ret scdr)))))
seq))))
;;; (sort sequence less?)
;;; sorts a array, string, or list non-destructively. It does this
@ -183,11 +183,11 @@
(define (sort seq less? . opt-key)
(define key (if (null? opt-key) #f (car opt-key)))
(cond ((array? seq)
(let ((dims (array-dimensions seq)))
(define newra (apply make-array seq dims))
(do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
(cdr sorted))
(i 0 (+ i 1)))
((null? sorted) newra)
(array-set! newra (car sorted) i))))
(else (sort:sort-list! (append seq '()) less? key))))
(let ((dims (array-dimensions seq)))
(define newra (apply make-array seq dims))
(do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
(cdr sorted))
(i 0 (+ i 1)))
((null? sorted) newra)
(array-set! newra (car sorted) i))))
(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)
(cond ((null? lst) #f)
((eq item (car lst)) start)
(#t (index-of item (cdr lst) (+ start 1)))))
((eq item (car lst)) start)
(#t (index-of item (cdr lst) (+ start 1)))))
(define (each f l)
(if (null? l) l
@ -41,31 +41,33 @@
(f t zero)
(f t (foldl t (lambda (e state) (foldtree-post f e state)) zero))))
; 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,
; while transformation follows evaluation order. this seems to be the most natural
; approach.
; (mapper tree state) - should return transformed tree given current state
; (folder tree state) - should return new state
;; 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, while transformation follows evaluation order. This seems to be the
;; most natural approach.
;;
;; (mapper tree state) - should return transformed tree given current state
;; (folder tree state) - should return new state
(define (map&fold t zero mapper folder)
(let ((head (and (pair? t) (car t))))
(cond ((eq? head 'quote)
t)
((or (eq? head 'the) (eq? head 'meta))
(list head
(cadr t)
(map&fold (caddr t) zero mapper folder)))
(else
(let ((new-s (folder t zero)))
(mapper
(if (pair? t)
; head symbol is a tag; never transform it
(cons (car t)
(map (lambda (e) (map&fold e new-s mapper folder))
(cdr t)))
t)
new-s))))))
t)
((or (eq? head 'the) (eq? head 'meta))
(list head
(cadr t)
(map&fold (caddr t) zero mapper folder)))
(else
(let ((new-s (folder t zero)))
(mapper
(if (pair? t)
; head symbol is a tag; never transform it
(cons (car t)
(map (lambda (e) (map&fold e new-s mapper folder))
(cdr t)))
t)
new-s))))))
; convert to proper list, i.e. remove "dots", and append
(define (append.2 l tail)
@ -77,11 +79,11 @@
; env is a list of lexical variables in effect at that point.
(define (lexical-walk f t)
(map&fold t () f
(lambda (tree state)
(if (and (eq? (car t) 'lambda)
(pair? (cdr t)))
(append.2 (cadr t) state)
state))))
(lambda (tree state)
(if (and (eq? (car t) 'lambda)
(pair? (cdr t)))
(append.2 (cadr t) state)
state))))
; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
(define (flatten-left-op op e)
@ -110,14 +112,14 @@
((pair? e)
(if (eq (car e) 'quote)
e
(let* ((newvs (and (eq (car e) 'lambda) (cadr e)))
(newenv (if newvs (cons newvs env) env)))
(if newvs
(cons 'lambda
(cons (cadr e)
(map (lambda (se) (lvc- se newenv))
(cddr e))))
(map (lambda (se) (lvc- se env)) e)))))
(let* ((newvs (and (eq (car e) 'lambda) (cadr e)))
(newenv (if newvs (cons newvs env) env)))
(if newvs
(cons 'lambda
(cons (cadr e)
(map (lambda (se) (lvc- se newenv))
(cddr e))))
(map (lambda (se) (lvc- se env)) e)))))
(#t e)))
(define (lexical-var-conversion e)
(lvc- e ()))
@ -125,32 +127,32 @@
; convert let to lambda
(define (let-expand e)
(maptree-post (lambda (n)
(if (and (pair? n) (eq (car n) 'let))
`((lambda ,(map car (cadr n)) ,@(cddr n))
,@(map cadr (cadr n)))
(if (and (pair? n) (eq (car n) 'let))
`((lambda ,(map car (cadr n)) ,@(cddr n))
,@(map cadr (cadr n)))
n))
e))
e))
; alpha renaming
; transl is an assoc list ((old-sym-name . new-sym-name) ...)
(define (alpha-rename e transl)
(map&fold e
()
; mapper: replace symbol if unbound
(lambda (t env)
(if (symbol? t)
(let ((found (assq t transl)))
(if (and found
(not (memq t env)))
(cdr found)
t))
t))
; folder: add locals to environment if entering a new scope
(lambda (t env)
(if (and (pair? t) (or (eq? (car t) 'let)
(eq? (car t) 'lambda)))
(append (cadr t) env)
env))))
()
; mapper: replace symbol if unbound
(lambda (t env)
(if (symbol? t)
(let ((found (assq t transl)))
(if (and found
(not (memq t env)))
(cdr found)
t))
t))
; folder: add locals to environment if entering a new scope
(lambda (t env)
(if (and (pair? t) (or (eq? (car t) 'let)
(eq? (car t) 'lambda)))
(append (cadr t) env)
env))))
; flatten op with any associativity
(define-macro (flatten-all-op op e)

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

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

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

@ -32,44 +32,44 @@
;
(define (match- p expr state)
(cond ((symbol? p)
(cond ((eq? p '_) state)
(else
(let ((capt (assq p state)))
(if capt
(and (equal? expr (cdr capt)) state)
(cons (cons p expr) state))))))
((procedure? p)
(and (p expr) state))
((pair? p)
(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 (match- (caddr p) expr state)
(cons (cons (cadr p) expr) state)))
((eq? (car p) '-$) ; greedy alternation for toplevel pattern
(match-alt (cdr p) () (list expr) state #f 1))
(else
(and (pair? expr)
(equal? (car p) (car expr))
(match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
(else
(and (equal? p expr) state))))
(cond ((eq? p '_) state)
(else
(let ((capt (assq p state)))
(if capt
(and (equal? expr (cdr capt)) state)
(cons (cons p expr) state))))))
((procedure? p)
(and (p expr) state))
((pair? p)
(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 (match- (caddr p) expr state)
(cons (cons (cadr p) expr) state)))
((eq? (car p) '-$) ; greedy alternation for toplevel pattern
(match-alt (cdr p) () (list expr) state #f 1))
(else
(and (pair? expr)
(equal? (car p) (car expr))
(match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
(else
(and (equal? p expr) state))))
; match an alternation
(define (match-alt alt prest expr state var L)
(if (null? alt) #f ; no alternatives left
(let ((subma (match- (car alt) (car expr) state)))
(or (and subma
(match-seq prest (cdr expr)
(if var
(cons (cons var (car expr))
subma)
subma)
(- L 1)))
(match-alt (cdr alt) prest expr state var L)))))
(or (and subma
(match-seq prest (cdr expr)
(if var
(cons (cons var (car expr))
subma)
subma)
(- L 1)))
(match-alt (cdr alt) prest expr state var L)))))
; match generalized kleene star (try consuming min to max)
(define (match-star p prest expr state var min max L)
@ -78,49 +78,49 @@
((> min max) #f)
; case 1: only allowed to match 0 subexpressions
((= max 0) (match-seq prest expr
(if var (cons (cons var (reverse sofar)) state)
state)
L))
(if var (cons (cons var (reverse sofar)) state)
state)
L))
; case 2: must match at least 1
((> min 0)
(and (match- p (car expr) state)
(match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
(cons (car expr) sofar))))
((> min 0)
(and (match- p (car expr) state)
(match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
(cons (car expr) sofar))))
; otherwise, must match either 0 or between 1 and max subexpressions
(else
(or (match-star- p prest expr state var 0 0 L sofar)
(match-star- p prest expr state var 1 max L sofar)))))
(else
(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 min max L ()))
; match sequences of expressions
(define (match-seq p expr state L)
(cond ((not state) #f)
((null? p) (if (null? expr) state #f))
(else
(let ((subp (car p))
(var #f))
(if (and (pair? subp)
(eq? (car subp) '--))
(begin (set! var (cadr subp))
(set! subp (caddr subp)))
#f)
(let ((head (if (pair? subp) (car subp) ())))
(cond ((eq? subp '...)
(match-star '_ (cdr p) expr state var 0 L L))
((eq? head '-*)
(match-star (cadr subp) (cdr p) expr state var 0 L L))
((eq? head '-+)
(match-star (cadr subp) (cdr p) expr state var 1 L L))
((eq? head '-?)
(match-star (cadr subp) (cdr p) expr state var 0 1 L))
((eq? head '-$)
(match-alt (cdr subp) (cdr p) expr state var L))
(else
(and (pair? expr)
(match-seq (cdr p) (cdr expr)
(match- (car p) (car expr) state)
(- L 1))))))))))
((null? p) (if (null? expr) state #f))
(else
(let ((subp (car p))
(var #f))
(if (and (pair? subp)
(eq? (car subp) '--))
(begin (set! var (cadr subp))
(set! subp (caddr subp)))
#f)
(let ((head (if (pair? subp) (car subp) ())))
(cond ((eq? subp '...)
(match-star '_ (cdr p) expr state var 0 L L))
((eq? head '-*)
(match-star (cadr subp) (cdr p) expr state var 0 L L))
((eq? head '-+)
(match-star (cadr subp) (cdr p) expr state var 1 L L))
((eq? head '-?)
(match-star (cadr subp) (cdr p) expr state var 0 1 L))
((eq? head '-$)
(match-alt (cdr subp) (cdr p) expr state var L))
(else
(and (pair? expr)
(match-seq (cdr p) (cdr expr)
(match- (car p) (car expr) state)
(- L 1))))))))))
(define (match p expr) (match- p expr (list (cons '__ expr))))
@ -128,15 +128,15 @@
(define (patargs p)
(define (patargs- p)
(cond ((and (symbol? p)
(not (member p metasymbols)))
(list p))
((pair? p)
(if (eq? (car p) '-/)
()
(delete-duplicates (apply append (map patargs- (cdr p))))))
(else ())))
(not (member p metasymbols)))
(list p))
((pair? p)
(if (eq? (car p) '-/)
()
(delete-duplicates (apply append (map patargs- (cdr p))))))
(else ())))
(cons '__ (patargs- p)))
; try to transform expr using a pattern-lambda from plist
@ -144,14 +144,14 @@
(define (apply-patterns plist expr)
(if (null? plist) expr
(if (procedure? plist)
(let ((enew (plist expr)))
(if (not enew)
expr
enew))
(let ((enew ((car plist) expr)))
(if (not enew)
(apply-patterns (cdr plist) expr)
enew)))))
(let ((enew (plist expr)))
(if (not enew)
expr
enew))
(let ((enew ((car plist) expr)))
(if (not enew)
(apply-patterns (cdr plist) expr)
enew)))))
; top-down fixed-point macroexpansion. this is a typical algorithm,
; but it may leave some structure that matches a pattern unexpanded.
@ -166,9 +166,9 @@
(if (not (pair? expr))
expr
(let ((enew (apply-patterns plist expr)))
(if (eq? enew expr)
; expr didn't change; move to subexpressions
(cons (car expr)
(map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
; expr changed; iterate
(pattern-expand plist enew)))))
(if (eq? enew expr)
; expr didn't change; move to subexpressions
(cons (car expr)
(map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
; expr changed; iterate
(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))
(set! r-gensym (lambda ()
(prog1 (symbol (string "%r:" ctr))
(set! ctr (+ ctr 1))))))
(prog1 (symbol (string "%r:" ctr))
(set! ctr (+ ctr 1))))))
(define (dollarsign-transform e)
(pattern-expand
(pattern-lambda ($ lhs name)
(let* ((g (if (not (pair? lhs)) lhs (r-gensym)))
(n (if (symbol? name)
name ;(symbol->string name)
name))
(expr `(r-call
r-aref ,g (index-in-strlist ,n (r-call attr ,g "names")))))
(if (not (pair? lhs))
expr
`(r-block (ref= ,g ,lhs) ,expr))))
(pattern-lambda
($ lhs name)
(let* ((g (if (not (pair? lhs)) lhs (r-gensym)))
(n (if (symbol? name)
name ;(symbol->string name)
name))
(expr `(r-call
r-aref ,g
(index-in-strlist ,n (r-call attr ,g "names")))))
(if (not (pair? lhs))
expr
`(r-block (ref= ,g ,lhs) ,expr))))
e))
; lower r expressions of the form f(lhs,...) <- rhs
@ -47,10 +49,11 @@
(pattern-expand
(pattern-lambda (-$ (<- (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 __)))
`(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ())
(,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g))
`(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ())
(,op ,lhs (r-call ,(symconcat f '<-)
,@(cddr (cadr __)) ,g))
,g)))
e))
@ -60,35 +63,36 @@
; added to its body
(define (gen-default-inits arglist)
(map (lambda (arg)
(let ((name (cadr arg))
(default (caddr arg)))
`(when (missing ,name)
(let ((name (cadr arg))
(default (caddr arg)))
`(when (missing ,name)
(<- ,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
(define (normalize-r-functions e)
(maptree-post (lambda (n)
(if (and (pair? n) (eq (car n) 'function))
`(lambda ,(func-argnames n)
(r-block ,@(gen-default-inits (cadr n))
,@(if (and (pair? (caddr n))
(eq (car (caddr n)) 'r-block))
(cdr (caddr n))
(if (and (pair? n) (eq (car n) 'function))
`(lambda ,(func-argnames n)
(r-block ,@(gen-default-inits (cadr n))
,@(if (and (pair? (caddr n))
(eq (car (caddr n)) 'r-block))
(cdr (caddr n))
(list (caddr n)))))
n))
e))
e))
(define (find-assigned-vars n)
(let ((vars ()))
(maptree-pre (lambda (s)
(if (not (pair? s)) s
(if (not (pair? s)) s
(cond ((eq (car s) 'lambda) ())
((eq (car s) '<-)
(set! vars (list-adjoin (cadr s) vars))
(cddr s))
(#t s))))
n)
n)
vars))
; introduce let based on assignment statements

10
scheme-tests/color.scm
View File

@ -1,6 +1,6 @@
; -*- scheme -*-
; dictionaries ----------------------------------------------------------------
; dictionaries ---------------------------------------------------------------
(define (dict-new) ())
(define (dict-extend dl key value)
@ -15,7 +15,7 @@
(define (dict-keys dl) (map car dl))
; graphs ----------------------------------------------------------------------
; graphs ---------------------------------------------------------------------
(define (graph-empty) (dict-new))
(define (graph-connect g n1 n2)
@ -39,7 +39,7 @@
(caar edge-list)
(cdar edge-list))))
; graph coloring --------------------------------------------------------------
; graph coloring -------------------------------------------------------------
(define (node-colorable? g coloring node-to-color color-of-node)
(not (member
color-of-node
@ -52,7 +52,7 @@
(define (try-each f lst)
(if (null? lst) #f
(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)
(cond
@ -72,7 +72,7 @@
(define (color-pairs pairs colors)
(color-graph (graph-from-edges pairs) colors))
; queens ----------------------------------------------------------------------
; queens ---------------------------------------------------------------------
(define (can-attack x y)
(let ((x1 (mod 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.
(define (bounded-equal a b N)
(cond ((<= N 0) 0)
((and (pair? a) (pair? b))
(let ((as
(bounded-equal (car a) (car b) (- N 1))))
(if (number? as)
0
(and as
(bounded-equal (cdr a) (cdr b) (- N 1))))))
(else (eq? a b))))
((and (pair? a) (pair? b))
(let ((as
(bounded-equal (car a) (car b) (- N 1))))
(if (number? as)
0
(and as
(bounded-equal (cdr a) (cdr b) (- N 1))))))
(else (eq? a b))))
; union-find algorithm
@ -23,8 +23,8 @@
(define (class table key)
(let ((c (hashtable-ref table key #f)))
(if (or (not c) (eq? c key))
c
(class table c))))
c
(class table c))))
; 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)
@ -34,7 +34,7 @@
(define (union! table a b c cb)
(let ((ca (if c c a)))
(if cb
(hashtable-set! table cb ca))
(hashtable-set! table cb ca))
(hashtable-set! table a ca)
(hashtable-set! table b ca)))
@ -43,26 +43,26 @@
; set them equal and move on.
(define (cyc-equal a b table)
(cond ((eq? a b) #t)
((not (and (pair? a) (pair? b))) (eq? a b))
(else
(let ((aa (car a)) (da (cdr a))
(ab (car b)) (db (cdr b)))
(cond ((or (not (eq? (atom? aa) (atom? ab)))
(not (eq? (atom? da) (atom? db)))) #f)
((and (atom? aa)
(not (eq? aa ab))) #f)
((and (atom? da)
(not (eq? da db))) #f)
(else
(let ((ca (class table a))
(cb (class table b)))
(if (and ca cb (eq? ca cb))
#t
(begin (union! table a b ca cb)
(and (cyc-equal aa ab table)
(cyc-equal da db table)))))))))))
((not (and (pair? a) (pair? b))) (eq? a b))
(else
(let ((aa (car a)) (da (cdr a))
(ab (car b)) (db (cdr b)))
(cond ((or (not (eq? (atom? aa) (atom? ab)))
(not (eq? (atom? da) (atom? db)))) #f)
((and (atom? aa)
(not (eq? aa ab))) #f)
((and (atom? da)
(not (eq? da db))) #f)
(else
(let ((ca (class table a))
(cb (class table b)))
(if (and ca cb (eq? ca cb))
#t
(begin (union! table a b ca cb)
(and (cyc-equal aa ab table)
(cyc-equal da db table)))))))))))
(define (equal a b)
(let ((guess (bounded-equal a b 2048)))
(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) ())
((null? (cdr lsts)) (car lsts))
(else (letrec ((append2 (lambda (l d)
(if (null? l) d
(cons (car l)
(append2 (cdr l) d))))))
(append2 (car lsts) (apply my-append (cdr lsts)))))))
(if (null? l) d
(cons (car l)
(append2 (cdr l) d))))))
(append2 (car lsts) (apply my-append (cdr lsts)))))))
(princ "append: ")
(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))
'((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)
(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))))
(time (ct))
(assert (equal? C
'((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)
(18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
(3 . d) (2 . c) (0 . b) (1 . a))))
'((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) (18 . e) (15 . a) (12 . a) (10 . e)
(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) ())
((null? (cdr lsts)) (car lsts))
(#t ((label append2 (lambda (l d)
(if (null? l) d
(cons (car l)
(append2 (cdr l) d)))))
(car lsts) (append-h (cdr lsts)))))))
(if (null? l) d
(cons (car l)
(append2 (cdr l) d)))))
(car lsts) (append-h (cdr lsts)))))))
lsts))
;(princ 'Hello '| | 'world! "\n")
@ -49,13 +49,13 @@
(if (<= n 0)
()
(let ((first (cons (f 0) ())))
((label map-int-
(lambda (acc i n)
(if (= i n)
first
(begin (set-cdr! acc (cons (f i) ()))
(map-int- (cdr acc) (+ i 1) n)))))
first 1 n))))
((label map-int-
(lambda (acc i n)
(if (= i n)
first
(begin (set-cdr! acc (cons (f i) ()))
(map-int- (cdr acc) (+ i 1) n)))))
first 1 n))))
|#
(define-macro (labl name fn)
@ -91,7 +91,7 @@
((label mapl-
(lambda (lsts)
(if (null? (car lsts)) ()
(begin (apply f lsts) (mapl- (map cdr lsts))))))
(begin (apply f lsts) (mapl- (map cdr lsts))))))
lsts))
; test to see if a symbol begins with :
@ -102,7 +102,7 @@
(define (swapad c)
(if (atom? c) c
(set-cdr! c (K (swapad (car c))
(set-car! c (swapad (cdr c)))))))
(set-car! c (swapad (cdr c)))))))
(define (without x l)
(filter (lambda (e) (not (eq e x))) l))
@ -120,14 +120,14 @@
;[` _ ,_ |- | . _ 2
;| (/_||||_()|_|_\|)
; |
; |
(define-macro (while- test . forms)
`((label -loop- (lambda ()
(if ,test
(begin ,@forms
(-loop-))
())))))
())))))
; 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
@ -183,22 +183,22 @@
(let ((acc (gensym)))
`(let ((,acc (list ())))
(cdr
(prog1 ,acc
(while ,cnd
(begin (set! ,acc
(cdr (set-cdr! ,acc (cons ,what ()))))
,@body)))))))
(prog1 ,acc
(while ,cnd
(begin (set! ,acc
(cdr (set-cdr! ,acc (cons ,what ()))))
,@body)))))))
(define-macro (accumulate-for var lo hi what . body)
(let ((acc (gensym)))
`(let ((,acc (list ())))
(cdr
(prog1 ,acc
(for ,lo ,hi
(lambda (,var)
(begin (set! ,acc
(cdr (set-cdr! ,acc (cons ,what ()))))
,@body))))))))
(prog1 ,acc
(for ,lo ,hi
(lambda (,var)
(begin (set! ,acc
(cdr (set-cdr! ,acc (cons ,what ()))))
,@body))))))))
(define (map-indexed f lst)
(if (atom? lst) lst
@ -211,84 +211,84 @@
(define (sub h n offs lst)
(let ((i (string.find h n offs)))
(if i
(sub h n (string.inc h i) (cons i lst))
(reverse! lst))))
(sub h n (string.inc h i) (cons i lst))
(reverse! lst))))
(sub haystack needle (if (null? offs) 0 (car offs)) ()))
(let ((*profiles* (table)))
(set! profile
(lambda (s)
(let ((f (top-level-value s)))
(put! *profiles* s (cons 0 0))
(set-top-level-value! s
(lambda args
(define tt (get *profiles* s))
(define count (car tt))
(define time (cdr tt))
(define t0 (time.now))
(define v (apply f args))
(set-cdr! tt (+ time (- (time.now) t0)))
(set-car! tt (+ count 1))
v)))))
(lambda (s)
(let ((f (top-level-value s)))
(put! *profiles* s (cons 0 0))
(set-top-level-value! s
(lambda args
(define tt (get *profiles* s))
(define count (car tt))
(define time (cdr tt))
(define t0 (time.now))
(define v (apply f args))
(set-cdr! tt (+ time (- (time.now) t0)))
(set-car! tt (+ count 1))
v)))))
(set! show-profiles
(lambda ()
(define pr (filter (lambda (x) (> (cadr x) 0))
(table.pairs *profiles*)))
(define width (+ 4
(apply max
(map (lambda (x)
(length (string x)))
(cons 'Function
(map car pr))))))
(princ (string.rpad "Function" width #\ )
"#Calls Time (seconds)")
(newline)
(princ (string.rpad "--------" width #\ )
"------ --------------")
(newline)
(for-each
(lambda (p)
(princ (string.rpad (string (caddr p)) width #\ )
(string.rpad (string (cadr p)) 11 #\ )
(car p))
(newline))
(simple-sort (map (lambda (l) (reverse (to-proper l)))
pr)))))
(lambda ()
(define pr (filter (lambda (x) (> (cadr x) 0))
(table.pairs *profiles*)))
(define width (+ 4
(apply max
(map (lambda (x)
(length (string x)))
(cons 'Function
(map car pr))))))
(princ (string.rpad "Function" width #\ )
"#Calls Time (seconds)")
(newline)
(princ (string.rpad "--------" width #\ )
"------ --------------")
(newline)
(for-each
(lambda (p)
(princ (string.rpad (string (caddr p)) width #\ )
(string.rpad (string (cadr p)) 11 #\ )
(car p))
(newline))
(simple-sort (map (lambda (l) (reverse (to-proper l)))
pr)))))
(set! clear-profiles
(lambda ()
(for-each (lambda (k)
(put! *profiles* k (cons 0 0)))
(table.keys *profiles*)))))
(lambda ()
(for-each (lambda (k)
(put! *profiles* k (cons 0 0)))
(table.keys *profiles*)))))
#;(for-each profile
'(emit encode-byte-code const-to-idx-vec
index-of lookup-sym in-env? any every
compile-sym compile-if compile-begin
compile-arglist expand builtin->instruction
compile-app separate nconc get-defined-vars
compile-in compile compile-f delete-duplicates
map length> length= count filter append
lastcdr to-proper reverse reverse! list->vector
table.foreach list-head list-tail assq memq assoc member
assv memv nreconc bq-process))
'(emit encode-byte-code const-to-idx-vec
index-of lookup-sym in-env? any every
compile-sym compile-if compile-begin
compile-arglist expand builtin->instruction
compile-app separate nconc get-defined-vars
compile-in compile compile-f delete-duplicates
map length> length= count filter append
lastcdr to-proper reverse reverse! list->vector
table.foreach list-head list-tail assq memq assoc member
assv memv nreconc bq-process))
(define (filt1 pred lst)
(define (filt1- pred lst accum)
(if (null? lst) accum
(if (pred (car lst))
(filt1- pred (cdr lst) (cons (car lst) accum))
(filt1- pred (cdr lst) accum))))
(if (pred (car lst))
(filt1- pred (cdr lst) (cons (car lst) accum))
(filt1- pred (cdr lst) accum))))
(filt1- pred lst ()))
(define (filto pred lst (accum ()))
(if (atom? lst) accum
(if (pred (car lst))
(filto pred (cdr lst) (cons (car lst) accum))
(filto pred (cdr lst) accum))))
(filto pred (cdr lst) (cons (car lst) accum))
(filto pred (cdr lst) accum))))
; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d))
(define (pairwise? pred . args)
(or (null? args)
(let f ((a (car args)) (d (cdr args)))
(or (null? d)
(and (pred a (car d)) (f (car d) (cdr d)))))))
(or (null? 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)
(begin (write x)
(newline)
(f (+ x 1))
0))
(newline)
(f (+ x 1))
0))

97
scheme-tests/unittest.scm
View File

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

2
scheme-tests/wt.scm
View File

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

3
scripts/build.sh
View File

@ -1,7 +1,8 @@
#!/bin/sh
set -eu
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"
builddir="build-$(uname | tr A-Z- a-z_)-$(uname -m | tr A-Z- a-z_)"
cd "$(dirname "$0")"/..