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

Clean up whitespace 

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

26
LICENSE
View File

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

2
c/equalhash.c
View File

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

2
c/equalhash.h
View File

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

42
c/lookup3.c
View File

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

4
scheme-boot/flisp.boot
View File

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

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

14
scheme-core/compiler.scm
View File

@ -244,10 +244,13 @@
(define (compile-sym g env s Is) (define (compile-sym g env s Is)
(let ((loc (lookup-sym s env 0 #t))) (let ((loc (lookup-sym s env 0 #t)))
(cond ((number? loc) (emit g (aref Is 0) loc)) (cond ((number? loc)
((number? (car loc)) (emit g (aref Is 1) (car loc) (cdr loc)) (emit g (aref Is 0) loc))
; update index of most distant captured frame ((number? (car loc))
(bcode:cdepth g (- (nnn (cdr env)) 1 (car loc)))) (emit g (aref Is 1) (car loc) (cdr loc))
;; update index of most distant captured frame
(bcode:cdepth
g (- (nnn (cdr env)) 1 (car loc))))
(else (else
(if (and (constant? s) (if (and (constant? s)
(printable? (top-level-value s))) (printable? (top-level-value s)))
@ -479,7 +482,8 @@
(expand-define x))) (expand-define x)))
(trycatch (compile-in g env #f `(lambda () ,(cadr x))) (trycatch (compile-in g env #f `(lambda () ,(cadr x)))
(unless (1arg-lambda? (caddr x)) (unless (1arg-lambda? (caddr x))
(error "trycatch: second form must be a 1-argument lambda")) (error
"trycatch: second form must be a 1-argument lambda"))
(compile-in g env #f (caddr x)) (compile-in g env #f (caddr x))
(emit g 'trycatch)) (emit g 'trycatch))
(else (compile-app g env tail? x)))))) (else (compile-app g env tail? x))))))

24
scheme-core/system.scm
View File

@ -113,7 +113,7 @@
(cond-clauses->if (cdr lst))))))))) (cond-clauses->if (cdr lst)))))))))
(cond-clauses->if clauses)) (cond-clauses->if clauses))
; standard procedures --------------------------------------------------------- ; standard procedures --------------------------------------------------------
(define (member item lst) (define (member item lst)
(cond ((atom? lst) #f) (cond ((atom? lst) #f)
@ -213,7 +213,7 @@
(apply consumer (cdr res)) (apply consumer (cdr res))
(consumer res)))))) (consumer res))))))
; list utilities -------------------------------------------------------------- ; list utilities -------------------------------------------------------------
(define (every pred lst) (define (every pred lst)
(or (atom? lst) (or (atom? lst)
@ -362,7 +362,7 @@
(cons elt (cons elt
(delete-duplicates tail))))))) (delete-duplicates tail)))))))
; backquote ------------------------------------------------------------------- ; backquote ------------------------------------------------------------------
(define (revappend l1 l2) (reverse- l2 l1)) (define (revappend l1 l2) (reverse- l2 l1))
(define (nreconc l1 l2) (reverse!- l2 l1)) (define (nreconc l1 l2) (reverse!- l2 l1))
@ -453,7 +453,7 @@
;; (... . x) ;; (... . x)
(cons 'nconc (reverse! (cons (bq-process p d) q))))))))) (cons 'nconc (reverse! (cons (bq-process p d) q)))))))))
; standard macros ------------------------------------------------------------- ; standard macros ------------------------------------------------------------
(define (quote-value v) (define (quote-value v)
(if (self-evaluating? v) (if (self-evaluating? v)
@ -554,7 +554,7 @@
(begin ,@body) (begin ,@body)
(begin ,@(map (lambda (v old) `(set! ,v ,old)) vars olds)))))) (begin ,@(map (lambda (v old) `(set! ,v ,old)) vars olds))))))
; exceptions ------------------------------------------------------------------ ; exceptions -----------------------------------------------------------------
(define (error . args) (raise (cons 'error args))) (define (error . args) (raise (cons 'error args)))
@ -576,7 +576,7 @@
(lambda (,e) (begin (,thk) (raise ,e)))) (lambda (,e) (begin (,thk) (raise ,e))))
(,thk))))) (,thk)))))
; debugging utilities --------------------------------------------------------- ; debugging utilities --------------------------------------------------------
(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr)))) (define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
@ -614,7 +614,7 @@
,expr ,expr
(princ "Elapsed time: " (- (time.now) ,t0) " seconds\n"))))) (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n")))))
; text I/O -------------------------------------------------------------------- ; text I/O -------------------------------------------------------------------
(define (print . args) (for-each write args)) (define (print . args) (for-each write args))
(define (princ . args) (define (princ . args)
@ -653,7 +653,7 @@
`(with-bindings ((*input-stream* ,stream)) `(with-bindings ((*input-stream* ,stream))
,@body)) ,@body))
; vector functions ------------------------------------------------------------ ; vector functions -----------------------------------------------------------
(define (list->vector l) (apply vector l)) (define (list->vector l) (apply vector l))
(define (vector->list v) (define (vector->list v)
@ -672,7 +672,7 @@
(aset! nv i (f (aref v i))))) (aset! nv i (f (aref v i)))))
nv)) nv))
; table functions ------------------------------------------------------------- ; table functions ------------------------------------------------------------
(define (table.pairs t) (define (table.pairs t)
(table.foldl (lambda (k v z) (cons (cons k v) z)) (table.foldl (lambda (k v z) (cons (cons k v) z))
@ -696,7 +696,7 @@
(define (table.foreach f t) (define (table.foreach f t)
(table.foldl (lambda (k v z) (begin (f k v) #t)) () t)) (table.foldl (lambda (k v z) (begin (f k v) #t)) () t))
; string functions ------------------------------------------------------------ ; string functions -----------------------------------------------------------
(define (string.tail s n) (string.sub s (string.inc s 0 n))) (define (string.tail s n) (string.sub s (string.inc s 0 n)))
@ -756,7 +756,7 @@
(cdr strlist)) (cdr strlist))
(io.tostring! b)))) (io.tostring! b))))
; toplevel -------------------------------------------------------------------- ; toplevel -------------------------------------------------------------------
(define (macrocall? e) (and (symbol? (car e)) (define (macrocall? e) (and (symbol? (car e))
(symbol-syntax (car e)))) (symbol-syntax (car e))))
@ -919,7 +919,7 @@
; _ ; _
; |_ _ _ |_ _ | . _ _ ; |_ _ _ |_ _ | . _ _
; | (-||||_(_)|__|_)|_) ; | (-||||_(_)|__|_)|_)
;-------------------|---------------------------------------------------------- ;-------------------|--
" 1)) " 1))

3
scheme-examples/cps.scm
View File

@ -284,7 +284,8 @@ todo:
* handle dotted arglists in lambda * handle dotted arglists in lambda
- optimize constant functions, e.g. (funcall/cc-0 #:g65 (lambda (#:g58) 'done)) - optimize constant functions, e.g.
(funcall/cc-0 #:g65 (lambda (#:g58) 'done))
- implement CPS version of apply - implement CPS version of apply

1
scheme-lib/psyntax.scm
View File

@ -4292,4 +4292,3 @@
((set! var val) (syntax exp2)) ((set! var val) (syntax exp2))
((id x (... ...)) (syntax (exp1 x (... ...)))) ((id x (... ...)) (syntax (exp1 x (... ...))))
(id (identifier? (syntax id)) (syntax exp1)))))))) (id (identifier? (syntax id)) (syntax exp1))))))))

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

@ -41,13 +41,15 @@
(f t zero) (f t zero)
(f t (foldl t (lambda (e state) (foldtree-post f e state)) zero)))) (f t (foldl t (lambda (e state) (foldtree-post f e state)) zero))))
; general tree transformer ;; general tree transformer
; folds in preorder (foldtree-pre), maps in postorder (maptree-post) ;;
; therefore state changes occur immediately, just by looking at the current node, ;; Folds in preorder (foldtree-pre), maps in postorder (maptree-post).
; while transformation follows evaluation order. this seems to be the most natural ;; Therefore state changes occur immediately, just by looking at the current
; approach. ;; node, while transformation follows evaluation order. This seems to be the
; (mapper tree state) - should return transformed tree given current state ;; most natural approach.
; (folder tree state) - should return new state ;;
;; (mapper tree state) - should return transformed tree given current state
;; (folder tree state) - should return new state
(define (map&fold t zero mapper folder) (define (map&fold t zero mapper folder)
(let ((head (and (pair? t) (car t)))) (let ((head (and (pair? t) (car t))))
(cond ((eq? head 'quote) (cond ((eq? head 'quote)

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

@ -26,13 +26,15 @@
(define (dollarsign-transform e) (define (dollarsign-transform e)
(pattern-expand (pattern-expand
(pattern-lambda ($ lhs name) (pattern-lambda
($ lhs name)
(let* ((g (if (not (pair? lhs)) lhs (r-gensym))) (let* ((g (if (not (pair? lhs)) lhs (r-gensym)))
(n (if (symbol? name) (n (if (symbol? name)
name ;(symbol->string name) name ;(symbol->string name)
name)) name))
(expr `(r-call (expr `(r-call
r-aref ,g (index-in-strlist ,n (r-call attr ,g "names"))))) r-aref ,g
(index-in-strlist ,n (r-call attr ,g "names")))))
(if (not (pair? lhs)) (if (not (pair? lhs))
expr expr
`(r-block (ref= ,g ,lhs) ,expr)))) `(r-block (ref= ,g ,lhs) ,expr))))
@ -50,7 +52,8 @@
(let ((g (if (pair? rhs) (r-gensym) rhs)) (let ((g (if (pair? rhs) (r-gensym) rhs))
(op (car __))) (op (car __)))
`(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ()) `(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ())
(,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g)) (,op ,lhs (r-call ,(symconcat f '<-)
,@(cddr (cadr __)) ,g))
,g))) ,g)))
e)) e))
@ -64,7 +67,8 @@
(default (caddr arg))) (default (caddr arg)))
`(when (missing ,name) `(when (missing ,name)
(<- ,name ,default)))) (<- ,name ,default))))
(filter (lambda (arg) (not (eq (caddr arg) missing-arg-tag))) arglist))) (filter (lambda (arg) (not (eq (caddr arg) missing-arg-tag)))
arglist)))
; convert r function expressions to lambda ; convert r function expressions to lambda
(define (normalize-r-functions e) (define (normalize-r-functions e)

8
scheme-tests/color.scm
View File

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

9
scheme-tests/printcases.scm
View File

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

8
scheme-tests/tcolor.scm
View File

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

13
scheme-tests/unittest.scm
View File

@ -5,7 +5,10 @@
`(eq? (car e) ',(car what))))))) `(eq? (car e) ',(car what)))))))
(define (every-int n) (define (every-int n)
(list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n) (list (fixnum n)
(int8 n) (uint8 n)
(int16 n) (uint16 n)
(int32 n) (uint32 n)
(int64 n) (uint64 n))) (int64 n) (uint64 n)))
(define (every-sint n) (define (every-sint n)
@ -214,10 +217,10 @@
(load "color.scm") (load "color.scm")
(assert (equal? (color-pairs (generate-5x5-pairs) '(a b c d e)) (assert (equal? (color-pairs (generate-5x5-pairs) '(a b c d e))
'((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e) '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b)
(19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d) (21 . e) (19 . b) (16 . c) (13 . c) (11 . b) (7 . e)
(18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e) (24 . c) (20 . d) (18 . e) (15 . a) (12 . a) (10 . e)
(3 . d) (2 . c) (0 . b) (1 . a)))) (6 . d) (5 . c) (4 . e) (3 . d) (2 . c) (0 . b) (1 . a))))
; hashing strange things ; hashing strange things
(assert (equal? (assert (equal?

3
scripts/build.sh
View File

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