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:
parent
09c6368668
commit
be9b2b364e
26
LICENSE
26
LICENSE
|
@ -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.
|
||||
|
|
|
@ -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))
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
#ifndef EQUALHASH_H
|
||||
#define EQUALHASH_H
|
||||
|
||||
#include "htableh.inc"
|
||||
#include "htableh_inc.h"
|
||||
|
||||
HTPROT(equalhash)
|
||||
|
||||
|
|
74
c/lookup3.c
74
c/lookup3.c
|
@ -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;
|
||||
|
|
|
@ -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
12
c/utils.h
|
@ -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))));
|
||||
|
|
|
@ -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?)
|
||||
|
|
|
@ -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
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -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*))
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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))))))))
|
||||
|
||||
|
|
|
@ -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))
|
||||
|