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

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.

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))

View File

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

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;

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 */

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))));

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?)

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

File diff suppressed because it is too large Load Diff

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*))

File diff suppressed because it is too large Load Diff

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

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

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))

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.

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))))))))

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))