From be9b2b364ec83b28f640acf5b949b635a3439b24 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Fri, 9 Aug 2019 17:18:36 +0300 Subject: [PATCH] Clean up whitespace - Tabs to spaces - Remove invisible whitespace at ends of lines - Break or shorten long lines (not for all files) --- LICENSE | 26 +- c/equalhash.c | 2 +- c/equalhash.h | 2 +- c/lookup3.c | 74 +- c/mt19937ar.c | 16 +- c/utils.h | 12 +- scheme-boot/flisp.boot | 4 +- scheme-core/aliases.scm | 64 +- scheme-core/compiler.scm | 1022 ++++++------ scheme-core/mkboot0.scm | 10 +- scheme-core/system.scm | 938 +++++------ scheme-examples/bq.scm | 146 +- scheme-examples/cps.scm | 13 +- scheme-examples/rule30.scm | 28 +- scheme-lib/lazy.scm | 8 +- scheme-lib/psyntax.scm | 55 +- scheme-lib/sort.scm | 214 +-- scheme-tests/ast/asttools.scm | 116 +- scheme-tests/ast/match-lsp.scm | 154 +- scheme-tests/ast/match.scm | 184 +-- scheme-tests/ast/rpasses-out.scm | 2646 +++++++++++++++--------------- scheme-tests/ast/rpasses.scm | 60 +- scheme-tests/color.scm | 10 +- scheme-tests/equal.scm | 60 +- scheme-tests/perf.scm | 8 +- scheme-tests/printcases.scm | 9 +- scheme-tests/tcolor.scm | 8 +- scheme-tests/test.scm | 170 +- scheme-tests/torture.scm | 6 +- scheme-tests/unittest.scm | 97 +- scheme-tests/wt.scm | 2 +- scripts/build.sh | 3 +- 32 files changed, 3092 insertions(+), 3075 deletions(-) diff --git a/LICENSE b/LICENSE index 778a605..bb0eeaf 100644 --- a/LICENSE +++ b/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. diff --git a/c/equalhash.c b/c/equalhash.c index da4c0b4..41353b5 100644 --- a/c/equalhash.c +++ b/c/equalhash.c @@ -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)) diff --git a/c/equalhash.h b/c/equalhash.h index 03a5a3c..2e0e9e9 100644 --- a/c/equalhash.h +++ b/c/equalhash.h @@ -1,7 +1,7 @@ #ifndef EQUALHASH_H #define EQUALHASH_H -#include "htableh.inc" +#include "htableh_inc.h" HTPROT(equalhash) diff --git a/c/lookup3.c b/c/lookup3.c index 24e1019..66ddd82 100644 --- a/c/lookup3.c +++ b/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; diff --git a/c/mt19937ar.c b/c/mt19937ar.c index 63faa49..553599d 100644 --- a/c/mt19937ar.c +++ b/c/mt19937ar.c @@ -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 */ diff --git a/c/utils.h b/c/utils.h index b24d97c..57e9c72 100644 --- a/c/utils.h +++ b/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)))); diff --git a/scheme-boot/flisp.boot b/scheme-boot/flisp.boot index 732cd2d..136e045 100644 --- a/scheme-boot/flisp.boot +++ b/scheme-boot/flisp.boot @@ -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?) diff --git a/scheme-core/aliases.scm b/scheme-core/aliases.scm index 88916c1..f129068 100644 --- a/scheme-core/aliases.scm +++ b/scheme-core/aliases.scm @@ -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 diff --git a/scheme-core/compiler.scm b/scheme-core/compiler.scm index 1a459dc..7c15fde 100644 --- a/scheme-core/compiler.scm +++ b/scheme-core/compiler.scm @@ -2,51 +2,51 @@ (define Instructions (let ((e (table)) - (keys - [nop dup pop call tcall jmp brf brt jmp.l brf.l brt.l ret - - eq? eqv? equal? atom? not null? boolean? symbol? - number? bound? pair? builtin? vector? fixnum? function? - - cons list car cdr set-car! set-cdr! - apply - - + - * / div0 = < compare - - vector aref aset! - - loadt loadf loadnil load0 load1 loadi8 - loadv loadv.l - loadg loadg.l - loada loada.l loadc loadc.l - setg setg.l - seta seta.l setc setc.l - - closure argc vargc trycatch for tapply - add2 sub2 neg largc lvargc - loada0 loada1 loadc00 loadc01 call.l tcall.l - brne brne.l cadr brnn brnn.l brn brn.l - optargs brbound keyargs - - dummy_t dummy_f dummy_nil])) + (keys + [nop dup pop call tcall jmp brf brt jmp.l brf.l brt.l ret + + eq? eqv? equal? atom? not null? boolean? symbol? + number? bound? pair? builtin? vector? fixnum? function? + + cons list car cdr set-car! set-cdr! + apply + + + - * / div0 = < compare + + vector aref aset! + + loadt loadf loadnil load0 load1 loadi8 + loadv loadv.l + loadg loadg.l + loada loada.l loadc loadc.l + setg setg.l + seta seta.l setc setc.l + + closure argc vargc trycatch for tapply + add2 sub2 neg largc lvargc + loada0 loada1 loadc00 loadc01 call.l tcall.l + brne brne.l cadr brnn brnn.l brn brn.l + optargs brbound keyargs + + dummy_t dummy_f dummy_nil])) (for 0 (1- (length keys)) - (lambda (i) - (put! e (aref keys i) i))))) + (lambda (i) + (put! e (aref keys i) i))))) (define arg-counts (table eq? 2 eqv? 2 - equal? 2 atom? 1 - not 1 null? 1 - boolean? 1 symbol? 1 - number? 1 bound? 1 - pair? 1 builtin? 1 - vector? 1 fixnum? 1 - cons 2 car 1 - cdr 1 set-car! 2 - set-cdr! 2 = 2 + equal? 2 atom? 1 + not 1 null? 1 + boolean? 1 symbol? 1 + number? 1 bound? 1 + pair? 1 builtin? 1 + vector? 1 fixnum? 1 + cons 2 car 1 + cdr 1 set-car! 2 + set-cdr! 2 = 2 < 2 compare 2 aref 2 aset! 3 - div0 2)) + div0 2)) (define (make-code-emitter) (vector () (table) 0 +inf.0)) (define (bcode:code b) (aref b 0)) @@ -56,67 +56,67 @@ ; get an index for a referenced value in a bytecode object (define (bcode:indexfor b v) (let ((const-to-idx (bcode:ctable b)) - (nconst (bcode:nconst b))) + (nconst (bcode:nconst b))) (if (has? const-to-idx v) - (get const-to-idx v) - (begin (put! const-to-idx v nconst) - (prog1 nconst - (aset! b 2 (+ nconst 1))))))) + (get const-to-idx v) + (begin (put! const-to-idx v nconst) + (prog1 nconst + (aset! b 2 (+ nconst 1))))))) (define (emit e inst . args) (if (null? args) (if (and (eq? inst 'car) (pair? (aref e 0)) - (eq? (car (aref e 0)) 'cdr)) - (set-car! (aref e 0) 'cadr) - (aset! e 0 (cons inst (aref e 0)))) + (eq? (car (aref e 0)) 'cdr)) + (set-car! (aref e 0) 'cadr) + (aset! e 0 (cons inst (aref e 0)))) (begin - (if (memq inst '(loadv loadg setg)) - (set! args (list (bcode:indexfor e (car args))))) - (let ((longform - (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l) - (loada loada.l) (seta seta.l))))) - (if (and longform - (> (car args) 255)) - (set! inst (cadr longform)))) - (let ((longform - (assq inst '((loadc loadc.l) (setc setc.l))))) - (if (and longform - (or (> (car args) 255) - (> (cadr args) 255))) - (set! inst (cadr longform)))) - (if (eq? inst 'loada) - (cond ((equal? args '(0)) - (set! inst 'loada0) - (set! args ())) - ((equal? args '(1)) - (set! inst 'loada1) - (set! args ())))) - (if (eq? inst 'loadc) - (cond ((equal? args '(0 0)) - (set! inst 'loadc00) - (set! args ())) - ((equal? args '(0 1)) - (set! inst 'loadc01) - (set! args ())))) + (if (memq inst '(loadv loadg setg)) + (set! args (list (bcode:indexfor e (car args))))) + (let ((longform + (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l) + (loada loada.l) (seta seta.l))))) + (if (and longform + (> (car args) 255)) + (set! inst (cadr longform)))) + (let ((longform + (assq inst '((loadc loadc.l) (setc setc.l))))) + (if (and longform + (or (> (car args) 255) + (> (cadr args) 255))) + (set! inst (cadr longform)))) + (if (eq? inst 'loada) + (cond ((equal? args '(0)) + (set! inst 'loada0) + (set! args ())) + ((equal? args '(1)) + (set! inst 'loada1) + (set! args ())))) + (if (eq? inst 'loadc) + (cond ((equal? args '(0 0)) + (set! inst 'loadc00) + (set! args ())) + ((equal? args '(0 1)) + (set! inst 'loadc01) + (set! args ())))) - (let ((lasti (if (pair? (aref e 0)) - (car (aref e 0)) ())) - (bc (aref e 0))) - (cond ((and - (eq? inst 'brf) - (cond ((and (eq? lasti 'not) - (eq? (cadr bc) 'null?)) - (aset! e 0 (cons (car args) (cons 'brn (cddr bc))))) - ((eq? lasti 'not) - (aset! e 0 (cons (car args) (cons 'brt (cdr bc))))) - ((eq? lasti 'eq?) - (aset! e 0 (cons (car args) (cons 'brne (cdr bc))))) - ((eq? lasti 'null?) - (aset! e 0 (cons (car args) (cons 'brnn (cdr bc))))) - (else #f)))) - ((and (eq? inst 'brt) (eq? lasti 'null?)) - (aset! e 0 (cons (car args) (cons 'brn (cdr bc))))) - (else - (aset! e 0 (nreconc (cons inst args) bc))))))) + (let ((lasti (if (pair? (aref e 0)) + (car (aref e 0)) ())) + (bc (aref e 0))) + (cond ((and + (eq? inst 'brf) + (cond ((and (eq? lasti 'not) + (eq? (cadr bc) 'null?)) + (aset! e 0 (cons (car args) (cons 'brn (cddr bc))))) + ((eq? lasti 'not) + (aset! e 0 (cons (car args) (cons 'brt (cdr bc))))) + ((eq? lasti 'eq?) + (aset! e 0 (cons (car args) (cons 'brne (cdr bc))))) + ((eq? lasti 'null?) + (aset! e 0 (cons (car args) (cons 'brnn (cdr bc))))) + (else #f)))) + ((and (eq? inst 'brt) (eq? lasti 'null?)) + (aset! e 0 (cons (car args) (cons 'brn (cdr bc))))) + (else + (aset! e 0 (nreconc (cons inst args) bc))))))) e) (define (make-label e) (gensym)) @@ -126,175 +126,178 @@ ; labels are fixed-up. (define (encode-byte-code e) (let* ((cl (reverse! e)) - (v (list->vector cl)) - (long? (>= (+ (length v) ; 1 byte for each entry, plus... - ; at most half the entries in this vector can be - ; instructions accepting 32-bit arguments - (* 3 (div0 (length v) 2))) - 65536))) + (v (list->vector cl)) + (long? (>= (+ (length v) ; 1 byte for each entry, plus... + ; at most half the entries in this vector can be + ; instructions accepting 32-bit arguments + (* 3 (div0 (length v) 2))) + 65536))) (let ((n (length v)) - (i 0) - (label-to-loc (table)) - (fixup-to-label (table)) - (bcode (buffer)) - (vi #f) - (nxt #f)) + (i 0) + (label-to-loc (table)) + (fixup-to-label (table)) + (bcode (buffer)) + (vi #f) + (nxt #f)) (io.write bcode #int32(0)) (while (< i n) - (begin - (set! vi (aref v i)) - (if (eq? vi 'label) - (begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode)) - (set! i (+ i 2))) - (begin - (io.write bcode - (byte - (get Instructions - (if long? - (case vi - (jmp 'jmp.l) - (brt 'brt.l) - (brf 'brf.l) - (brne 'brne.l) - (brnn 'brnn.l) - (brn 'brn.l) - (else vi)) - vi)))) - (set! i (+ i 1)) - (set! nxt (if (< i n) (aref v i) #f)) - (cond ((memq vi '(jmp brf brt brne brnn brn)) - (put! fixup-to-label (sizeof bcode) nxt) - (io.write bcode ((if long? int32 int16) 0)) - (set! i (+ i 1))) - ((eq? vi 'brbound) - (io.write bcode (int32 nxt)) - (set! i (+ i 1))) - ((number? nxt) - (case vi - ((loadv.l loadg.l setg.l loada.l seta.l - largc lvargc call.l tcall.l) - (io.write bcode (int32 nxt)) - (set! i (+ i 1))) - - ((loadc setc) ; 2 uint8 args - (io.write bcode (uint8 nxt)) - (set! i (+ i 1)) - (io.write bcode (uint8 (aref v i))) - (set! i (+ i 1))) - - ((loadc.l setc.l optargs keyargs) ; 2 int32 args - (io.write bcode (int32 nxt)) - (set! i (+ i 1)) - (io.write bcode (int32 (aref v i))) - (set! i (+ i 1)) - (if (eq? vi 'keyargs) - (begin (io.write bcode (int32 (aref v i))) - (set! i (+ i 1))))) - - (else - ; other number arguments are always uint8 - (io.write bcode (uint8 nxt)) - (set! i (+ i 1))))) - (else #f)))))) + (begin + (set! vi (aref v i)) + (if (eq? vi 'label) + (begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode)) + (set! i (+ i 2))) + (begin + (io.write bcode + (byte + (get Instructions + (if long? + (case vi + (jmp 'jmp.l) + (brt 'brt.l) + (brf 'brf.l) + (brne 'brne.l) + (brnn 'brnn.l) + (brn 'brn.l) + (else vi)) + vi)))) + (set! i (+ i 1)) + (set! nxt (if (< i n) (aref v i) #f)) + (cond ((memq vi '(jmp brf brt brne brnn brn)) + (put! fixup-to-label (sizeof bcode) nxt) + (io.write bcode ((if long? int32 int16) 0)) + (set! i (+ i 1))) + ((eq? vi 'brbound) + (io.write bcode (int32 nxt)) + (set! i (+ i 1))) + ((number? nxt) + (case vi + ((loadv.l loadg.l setg.l loada.l seta.l + largc lvargc call.l tcall.l) + (io.write bcode (int32 nxt)) + (set! i (+ i 1))) + + ((loadc setc) ; 2 uint8 args + (io.write bcode (uint8 nxt)) + (set! i (+ i 1)) + (io.write bcode (uint8 (aref v i))) + (set! i (+ i 1))) + + ((loadc.l setc.l optargs keyargs) ; 2 int32 args + (io.write bcode (int32 nxt)) + (set! i (+ i 1)) + (io.write bcode (int32 (aref v i))) + (set! i (+ i 1)) + (if (eq? vi 'keyargs) + (begin (io.write bcode (int32 (aref v i))) + (set! i (+ i 1))))) + + (else + ; other number arguments are always uint8 + (io.write bcode (uint8 nxt)) + (set! i (+ i 1))))) + (else #f)))))) (table.foreach (lambda (addr labl) - (begin (io.seek bcode addr) - (io.write bcode ((if long? int32 int16) - (- (get label-to-loc labl) - addr))))) + (begin (io.seek bcode addr) + (io.write bcode ((if long? int32 int16) + (- (get label-to-loc labl) + addr))))) fixup-to-label) (io.tostring! bcode)))) (define (const-to-idx-vec e) (let ((cvec (vector.alloc (bcode:nconst e)))) (table.foreach (lambda (val idx) (aset! cvec idx val)) - (bcode:ctable e)) + (bcode:ctable e)) cvec)) (define (index-of item lst start) (cond ((null? lst) #f) - ((eq? item (car lst)) start) - (else (index-of item (cdr lst) (+ start 1))))) + ((eq? item (car lst)) start) + (else (index-of item (cdr lst) (+ start 1))))) (define (in-env? s env) (and (pair? env) (or (memq s (car env)) - (in-env? s (cdr env))))) + (in-env? s (cdr env))))) (define (lookup-sym s env lev arg?) (if (null? env) '(global) (let* ((curr (car env)) - (i (index-of s curr 0))) - (if i - (if arg? - i - (cons lev i)) - (lookup-sym s - (cdr env) - (if (or arg? (null? curr)) lev (+ lev 1)) - #f))))) + (i (index-of s curr 0))) + (if i + (if arg? + i + (cons lev i)) + (lookup-sym s + (cdr env) + (if (or arg? (null? curr)) lev (+ lev 1)) + #f))))) ; number of non-nulls (define (nnn e) (count (lambda (x) (not (null? x))) e)) (define (printable? x) (not (or (iostream? x) - (eof-object? x)))) + (eof-object? x)))) (define (compile-sym g env s Is) (let ((loc (lookup-sym s env 0 #t))) - (cond ((number? loc) (emit g (aref Is 0) loc)) - ((number? (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 - (if (and (constant? s) - (printable? (top-level-value s))) - (emit g 'loadv (top-level-value s)) - (emit g (aref Is 2) s)))))) + (cond ((number? loc) + (emit g (aref Is 0) loc)) + ((number? (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 + (if (and (constant? s) + (printable? (top-level-value s))) + (emit g 'loadv (top-level-value s)) + (emit g (aref Is 2) s)))))) (define (compile-if g env tail? x) (let ((elsel (make-label g)) - (endl (make-label g)) - (test (cadr x)) - (then (caddr x)) - (else (if (pair? (cdddr x)) - (cadddr x) - (void)))) + (endl (make-label g)) + (test (cadr x)) + (then (caddr x)) + (else (if (pair? (cdddr x)) + (cadddr x) + (void)))) (cond ((eq? test #t) - (compile-in g env tail? then)) - ((eq? test #f) - (compile-in g env tail? else)) - (else - (compile-in g env #f test) - (emit g 'brf elsel) - (compile-in g env tail? then) - (if tail? - (emit g 'ret) - (emit g 'jmp endl)) - (mark-label g elsel) - (compile-in g env tail? else) - (mark-label g endl))))) + (compile-in g env tail? then)) + ((eq? test #f) + (compile-in g env tail? else)) + (else + (compile-in g env #f test) + (emit g 'brf elsel) + (compile-in g env tail? then) + (if tail? + (emit g 'ret) + (emit g 'jmp endl)) + (mark-label g elsel) + (compile-in g env tail? else) + (mark-label g endl))))) (define (compile-begin g env tail? forms) (cond ((atom? forms) (compile-in g env tail? (void))) - ((atom? (cdr forms)) - (compile-in g env tail? (car forms))) - (else - (compile-in g env #f (car forms)) - (emit g 'pop) - (compile-begin g env tail? (cdr forms))))) + ((atom? (cdr forms)) + (compile-in g env tail? (car forms))) + (else + (compile-in g env #f (car forms)) + (emit g 'pop) + (compile-begin g env tail? (cdr forms))))) (define (compile-prog1 g env x) (compile-in g env #f (cadr x)) (if (pair? (cddr x)) (begin (compile-begin g env #f (cddr x)) - (emit g 'pop)))) + (emit g 'pop)))) (define (compile-while g env cond body) (let ((top (make-label g)) - (end (make-label g))) + (end (make-label g))) (compile-in g env #f (void)) (mark-label g top) (compile-in g env #f cond) @@ -314,22 +317,22 @@ (define (compile-for g env lo hi func) (if (1arg-lambda? func) (begin (compile-in g env #f lo) - (compile-in g env #f hi) - (compile-in g env #f func) - (emit g 'for)) + (compile-in g env #f hi) + (compile-in g env #f func) + (emit g 'for)) (error "for: third form must be a 1-argument lambda"))) (define (compile-short-circuit g env tail? forms default branch) (cond ((atom? forms) (compile-in g env tail? default)) - ((atom? (cdr forms)) (compile-in g env tail? (car forms))) - (else - (let ((end (make-label g))) - (compile-in g env #f (car forms)) - (emit g 'dup) - (emit g branch end) - (emit g 'pop) - (compile-short-circuit g env tail? (cdr forms) default branch) - (mark-label g end))))) + ((atom? (cdr forms)) (compile-in g env tail? (car forms))) + (else + (let ((end (make-label g))) + (compile-in g env #f (car forms)) + (emit g 'dup) + (emit g branch end) + (emit g 'pop) + (compile-short-circuit g env tail? (cdr forms) default branch) + (mark-label g end))))) (define (compile-and g env tail? forms) (compile-short-circuit g env tail? forms #t 'brf)) @@ -338,212 +341,213 @@ (define (compile-arglist g env lst) (for-each (lambda (a) - (compile-in g env #f a)) - lst) + (compile-in g env #f a)) + lst) (length lst)) (define (argc-error head count) (error "compile error: " head " expects " count - (if (= count 1) - " argument." - " arguments."))) + (if (= count 1) + " argument." + " arguments."))) (define builtin->instruction (let ((b2i (table number? 'number? cons 'cons - fixnum? 'fixnum? equal? 'equal? - eq? 'eq? symbol? 'symbol? - div0 'div0 builtin? 'builtin? - aset! 'aset! - '- boolean? 'boolean? not 'not - apply 'apply atom? 'atom? - set-cdr! 'set-cdr! / '/ - function? 'function? vector 'vector - list 'list bound? 'bound? - < '< * '* cdr 'cdr null? 'null? - + '+ eqv? 'eqv? compare 'compare aref 'aref - set-car! 'set-car! car 'car - pair? 'pair? = '= vector? 'vector?))) + fixnum? 'fixnum? equal? 'equal? + eq? 'eq? symbol? 'symbol? + div0 'div0 builtin? 'builtin? + aset! 'aset! - '- boolean? 'boolean? not 'not + apply 'apply atom? 'atom? + set-cdr! 'set-cdr! / '/ + function? 'function? vector 'vector + list 'list bound? 'bound? + < '< * '* cdr 'cdr null? 'null? + + '+ eqv? 'eqv? compare 'compare aref 'aref + set-car! 'set-car! car 'car + pair? 'pair? = '= vector? 'vector?))) (lambda (b) (get b2i b #f)))) (define (compile-builtin-call g env tail? x head b nargs) (let ((count (get arg-counts head #f))) (if (and count - (not (length= (cdr x) count))) - (argc-error b count)) + (not (length= (cdr x) count))) + (argc-error b count)) (case b ; handle special cases of vararg builtins (list (if (= nargs 0) (emit g 'loadnil) (emit g b nargs))) (+ (cond ((= nargs 0) (emit g 'load0)) - ((= nargs 2) (emit g 'add2)) - (else (emit g b nargs)))) + ((= nargs 2) (emit g 'add2)) + (else (emit g b nargs)))) (- (cond ((= nargs 0) (argc-error b 1)) - ((= nargs 1) (emit g 'neg)) - ((= nargs 2) (emit g 'sub2)) - (else (emit g b nargs)))) + ((= nargs 1) (emit g 'neg)) + ((= nargs 2) (emit g 'sub2)) + (else (emit g b nargs)))) (* (if (= nargs 0) (emit g 'load1) - (emit g b nargs))) + (emit g b nargs))) (/ (if (= nargs 0) - (argc-error b 1) - (emit g b nargs))) + (argc-error b 1) + (emit g b nargs))) (vector (if (= nargs 0) - (emit g 'loadv []) - (emit g b nargs))) + (emit g 'loadv []) + (emit g b nargs))) (apply (if (< nargs 2) - (argc-error b 2) - (emit g (if tail? 'tapply 'apply) nargs))) + (argc-error b 2) + (emit g (if tail? 'tapply 'apply) nargs))) (else (emit g b))))) (define (compile-app g env tail? x) (let ((head (car x))) (let ((head - (if (and (symbol? head) - (not (in-env? head env)) - (bound? head) - (constant? head) - (builtin? (top-level-value head))) - (top-level-value head) - head))) + (if (and (symbol? head) + (not (in-env? head env)) + (bound? head) + (constant? head) + (builtin? (top-level-value head))) + (top-level-value head) + head))) (if (length> (cdr x) 255) - ; more than 255 arguments, need long versions of instructions - (begin (compile-in g env #f head) - (let ((nargs (compile-arglist g env (cdr x)))) - (emit g (if tail? 'tcall.l 'call.l) nargs))) - (let ((b (and (builtin? head) - (builtin->instruction head)))) - (if (and (eq? head 'cadr) - (not (in-env? head env)) - (equal? (top-level-value 'cadr) cadr) - (length= x 2)) - (begin (compile-in g env #f (cadr x)) - (emit g 'cadr)) - (begin - (if (not b) - (compile-in g env #f head)) - (let ((nargs (compile-arglist g env (cdr x)))) - (if b - (compile-builtin-call g env tail? x head b nargs) - (emit g (if tail? 'tcall 'call) nargs)))))))))) + ; more than 255 arguments, need long versions of instructions + (begin (compile-in g env #f head) + (let ((nargs (compile-arglist g env (cdr x)))) + (emit g (if tail? 'tcall.l 'call.l) nargs))) + (let ((b (and (builtin? head) + (builtin->instruction head)))) + (if (and (eq? head 'cadr) + (not (in-env? head env)) + (equal? (top-level-value 'cadr) cadr) + (length= x 2)) + (begin (compile-in g env #f (cadr x)) + (emit g 'cadr)) + (begin + (if (not b) + (compile-in g env #f head)) + (let ((nargs (compile-arglist g env (cdr x)))) + (if b + (compile-builtin-call g env tail? x head b nargs) + (emit g (if tail? 'tcall 'call) nargs)))))))))) (define (expand-define x) (let ((form (cadr x)) - (body (if (pair? (cddr x)) - (cddr x) - (if (symbol? (cadr x)) - `(,(void)) - (error "compile error: invalid syntax " - (print-to-string x)))))) + (body (if (pair? (cddr x)) + (cddr x) + (if (symbol? (cadr x)) + `(,(void)) + (error "compile error: invalid syntax " + (print-to-string x)))))) (if (symbol? form) - `(set! ,form ,(car body)) - `(set! ,(car form) - (lambda ,(cdr form) ,@body . ,(car form)))))) + `(set! ,form ,(car body)) + `(set! ,(car form) + (lambda ,(cdr form) ,@body . ,(car form)))))) (define (fits-i8 x) (and (fixnum? x) (>= x -128) (<= x 127))) (define (compile-in g env tail? x) (cond ((symbol? x) (compile-sym g env x [loada loadc loadg])) - ((atom? x) - (cond ((eq? x 0) (emit g 'load0)) - ((eq? x 1) (emit g 'load1)) - ((eq? x #t) (emit g 'loadt)) - ((eq? x #f) (emit g 'loadf)) - ((eq? x ()) (emit g 'loadnil)) - ((fits-i8 x) (emit g 'loadi8 x)) - ((eof-object? x) - (compile-in g env tail? (list (top-level-value 'eof-object)))) - (else (emit g 'loadv x)))) - ((or (not (symbol? (car x))) (bound? (car x)) (in-env? (car x) env)) - (compile-app g env tail? x)) - (else - (case (car x) - (quote (if (self-evaluating? (cadr x)) - (compile-in g env tail? (cadr x)) - (emit g 'loadv (cadr x)))) - (if (compile-if g env tail? x)) - (begin (compile-begin g env tail? (cdr x))) - (prog1 (compile-prog1 g env x)) - (lambda (receive (the-f dept) (compile-f- env x) - (begin (emit g 'loadv the-f) - (bcode:cdepth g dept) - (if (< dept (nnn env)) - (emit g 'closure))))) - (and (compile-and g env tail? (cdr x))) - (or (compile-or g env tail? (cdr x))) - (while (compile-while g env (cadr x) (cons 'begin (cddr x)))) - (for (compile-for g env (cadr x) (caddr x) (cadddr x))) - (return (compile-in g env #t (cadr x)) - (emit g 'ret)) - (set! (compile-in g env #f (caddr x)) - (or (symbol? (cadr x)) - (error "set!: second argument must be a symbol")) - (compile-sym g env (cadr x) [seta setc setg])) - (define (compile-in g env tail? - (expand-define x))) - (trycatch (compile-in g env #f `(lambda () ,(cadr x))) - (unless (1arg-lambda? (caddr x)) - (error "trycatch: second form must be a 1-argument lambda")) - (compile-in g env #f (caddr x)) - (emit g 'trycatch)) - (else (compile-app g env tail? x)))))) + ((atom? x) + (cond ((eq? x 0) (emit g 'load0)) + ((eq? x 1) (emit g 'load1)) + ((eq? x #t) (emit g 'loadt)) + ((eq? x #f) (emit g 'loadf)) + ((eq? x ()) (emit g 'loadnil)) + ((fits-i8 x) (emit g 'loadi8 x)) + ((eof-object? x) + (compile-in g env tail? (list (top-level-value 'eof-object)))) + (else (emit g 'loadv x)))) + ((or (not (symbol? (car x))) (bound? (car x)) (in-env? (car x) env)) + (compile-app g env tail? x)) + (else + (case (car x) + (quote (if (self-evaluating? (cadr x)) + (compile-in g env tail? (cadr x)) + (emit g 'loadv (cadr x)))) + (if (compile-if g env tail? x)) + (begin (compile-begin g env tail? (cdr x))) + (prog1 (compile-prog1 g env x)) + (lambda (receive (the-f dept) (compile-f- env x) + (begin (emit g 'loadv the-f) + (bcode:cdepth g dept) + (if (< dept (nnn env)) + (emit g 'closure))))) + (and (compile-and g env tail? (cdr x))) + (or (compile-or g env tail? (cdr x))) + (while (compile-while g env (cadr x) (cons 'begin (cddr x)))) + (for (compile-for g env (cadr x) (caddr x) (cadddr x))) + (return (compile-in g env #t (cadr x)) + (emit g 'ret)) + (set! (compile-in g env #f (caddr x)) + (or (symbol? (cadr x)) + (error "set!: second argument must be a symbol")) + (compile-sym g env (cadr x) [seta setc setg])) + (define (compile-in g env tail? + (expand-define x))) + (trycatch (compile-in g env #f `(lambda () ,(cadr x))) + (unless (1arg-lambda? (caddr x)) + (error + "trycatch: second form must be a 1-argument lambda")) + (compile-in g env #f (caddr x)) + (emit g 'trycatch)) + (else (compile-app g env tail? x)))))) (define (compile-f env f) (receive (ff ignore) - (compile-f- env f) - ff)) + (compile-f- env f) + ff)) (define get-defined-vars (letrec ((get-defined-vars- - (lambda (expr) - (cond ((atom? expr) ()) - ((and (eq? (car expr) 'define) - (pair? (cdr expr))) - (or (and (symbol? (cadr expr)) - (list (cadr expr))) - (and (pair? (cadr expr)) - (symbol? (caadr expr)) - (list (caadr expr))) - ())) - ((eq? (car expr) 'begin) - (apply nconc (map get-defined-vars- (cdr expr)))) - (else ()))))) + (lambda (expr) + (cond ((atom? expr) ()) + ((and (eq? (car expr) 'define) + (pair? (cdr expr))) + (or (and (symbol? (cadr expr)) + (list (cadr expr))) + (and (pair? (cadr expr)) + (symbol? (caadr expr)) + (list (caadr expr))) + ())) + ((eq? (car expr) 'begin) + (apply nconc (map get-defined-vars- (cdr expr)))) + (else ()))))) (lambda (expr) (delete-duplicates (get-defined-vars- expr))))) (define (keyword-arg? x) (and (pair? x) (keyword? (car x)))) (define (keyword->symbol k) (if (keyword? k) (symbol (let ((s (string k))) - (string.sub s 0 (string.dec s (length s))))) + (string.sub s 0 (string.dec s (length s))))) k)) (define (lambda-arg-names argl) (map! (lambda (s) (if (pair? s) (keyword->symbol (car s)) s)) - (to-proper argl))) + (to-proper argl))) (define (lambda-vars l) (define (check-formals l o opt kw) (cond ((or (null? l) (symbol? l)) #t) - ((and (pair? l) (symbol? (car l))) - (if (or opt kw) - (error "compile error: invalid argument list " - o ". optional arguments must come after required.") - (check-formals (cdr l) o opt kw))) - ((and (pair? l) (pair? (car l))) - (unless (and (length= (car l) 2) - (symbol? (caar l))) - (error "compile error: invalid optional argument " (car l) - " in list " o)) - (if (keyword? (caar l)) - (check-formals (cdr l) o opt #t) - (if kw - (error "compile error: invalid argument list " - o ". keyword arguments must come last.") - (check-formals (cdr l) o #t kw)))) - ((pair? l) - (error "compile error: invalid formal argument " (car l) - " in list " o)) - (else - (if (eq? l o) - (error "compile error: invalid argument list " o) - (error "compile error: invalid formal argument " l - " in list " o))))) + ((and (pair? l) (symbol? (car l))) + (if (or opt kw) + (error "compile error: invalid argument list " + o ". optional arguments must come after required.") + (check-formals (cdr l) o opt kw))) + ((and (pair? l) (pair? (car l))) + (unless (and (length= (car l) 2) + (symbol? (caar l))) + (error "compile error: invalid optional argument " (car l) + " in list " o)) + (if (keyword? (caar l)) + (check-formals (cdr l) o opt #t) + (if kw + (error "compile error: invalid argument list " + o ". keyword arguments must come last.") + (check-formals (cdr l) o #t kw)))) + ((pair? l) + (error "compile error: invalid formal argument " (car l) + " in list " o)) + (else + (if (eq? l o) + (error "compile error: invalid argument list " o) + (error "compile error: invalid formal argument " l + " in list " o))))) (check-formals l l #f #f) (lambda-arg-names l)) @@ -551,22 +555,22 @@ ; i is the lexical var index of the opt arg to process next (if (pair? opta) (let ((nxt (make-label g))) - (emit g 'brbound i) - (emit g 'brt nxt) - (compile-in g (cons (list-head vars i) env) #f (cadar opta)) - (emit g 'seta i) - (emit g 'pop) - (mark-label g nxt) - (emit-optional-arg-inits g env (cdr opta) vars (+ i 1))))) + (emit g 'brbound i) + (emit g 'brt nxt) + (compile-in g (cons (list-head vars i) env) #f (cadar opta)) + (emit g 'seta i) + (emit g 'pop) + (mark-label g nxt) + (emit-optional-arg-inits g env (cdr opta) vars (+ i 1))))) #;(define (free-vars e) (cond ((symbol? e) (list e)) - ((or (atom? e) (eq? (car e) 'quote)) ()) - ((eq? (car e) 'lambda) - (diff (free-vars (cddr e)) - (nconc (get-defined-vars (cons 'begin (cddr e))) - (lambda-arg-names (cadr e))))) - (else (delete-duplicates (apply nconc (map free-vars (cdr e))))))) + ((or (atom? e) (eq? (car e) 'quote)) ()) + ((eq? (car e) 'lambda) + (diff (free-vars (cddr e)) + (nconc (get-defined-vars (cons 'begin (cddr e))) + (lambda-arg-names (cadr e))))) + (else (delete-duplicates (apply nconc (map free-vars (cdr e))))))) (define compile-f- (let ((*defines-processed-token* (gensym))) @@ -579,72 +583,72 @@ (lambda (env f) ; convert lambda to one body expression and process internal defines (define (lambda-body e) - (let ((B (if (pair? (cddr e)) - (if (pair? (cdddr e)) - (cons 'begin (cddr e)) - (caddr e)) - (void)))) - (let ((V (get-defined-vars B))) - (if (null? V) - B - (cons (list* 'lambda V B *defines-processed-token*) - (map (lambda (x) (void)) V)))))) + (let ((B (if (pair? (cddr e)) + (if (pair? (cdddr e)) + (cons 'begin (cddr e)) + (caddr e)) + (void)))) + (let ((V (get-defined-vars B))) + (if (null? V) + B + (cons (list* 'lambda V B *defines-processed-token*) + (map (lambda (x) (void)) V)))))) (define (lam:body f) - (if (eq? (lastcdr f) *defines-processed-token*) - (caddr f) - (lambda-body f))) - + (if (eq? (lastcdr f) *defines-processed-token*) + (caddr f) + (lambda-body f))) + (let ((g (make-code-emitter)) - (args (cadr f)) - (atail (lastcdr (cadr f))) - (vars (lambda-vars (cadr f))) - (opta (filter pair? (cadr f))) - (name (if (eq? (lastcdr f) *defines-processed-token*) - 'lambda - (lastcdr f)))) - (let* ((nargs (if (atom? args) 0 (length args))) - (nreq (- nargs (length opta))) - (kwa (filter keyword-arg? opta))) + (args (cadr f)) + (atail (lastcdr (cadr f))) + (vars (lambda-vars (cadr f))) + (opta (filter pair? (cadr f))) + (name (if (eq? (lastcdr f) *defines-processed-token*) + 'lambda + (lastcdr f)))) + (let* ((nargs (if (atom? args) 0 (length args))) + (nreq (- nargs (length opta))) + (kwa (filter keyword-arg? opta))) - ; emit argument checking prologue - (if (not (null? opta)) - (begin - (if (null? kwa) - (emit g 'optargs nreq - (if (null? atail) nargs (- nargs))) - (begin - (bcode:indexfor g (make-perfect-hash-table - (map cons - (map car kwa) - (iota (length kwa))))) - (emit g 'keyargs nreq (length kwa) - (if (null? atail) nargs (- nargs))))) - (emit-optional-arg-inits g env opta vars nreq))) + ; emit argument checking prologue + (if (not (null? opta)) + (begin + (if (null? kwa) + (emit g 'optargs nreq + (if (null? atail) nargs (- nargs))) + (begin + (bcode:indexfor g (make-perfect-hash-table + (map cons + (map car kwa) + (iota (length kwa))))) + (emit g 'keyargs nreq (length kwa) + (if (null? atail) nargs (- nargs))))) + (emit-optional-arg-inits g env opta vars nreq))) - (cond ((> nargs 255) (emit g (if (null? atail) - 'largc 'lvargc) - nargs)) - ((not (null? atail)) (emit g 'vargc nargs)) - ((null? opta) (emit g 'argc nargs))) + (cond ((> nargs 255) (emit g (if (null? atail) + 'largc 'lvargc) + nargs)) + ((not (null? atail)) (emit g 'vargc nargs)) + ((null? opta) (emit g 'argc nargs))) - ; compile body and return - (compile-in g (cons vars env) #t (lam:body f)) - (emit g 'ret) - (values (function (encode-byte-code (bcode:code g)) - (const-to-idx-vec g) name) - (aref g 3))))))) + ; compile body and return + (compile-in g (cons vars env) #t (lam:body f)) + (emit g 'ret) + (values (function (encode-byte-code (bcode:code g)) + (const-to-idx-vec g) name) + (aref g 3))))))) (define (compile f) (compile-f () f)) (define (ref-int32-LE a i) (int32 (+ (ash (aref a (+ i 0)) 0) - (ash (aref a (+ i 1)) 8) - (ash (aref a (+ i 2)) 16) - (ash (aref a (+ i 3)) 24)))) + (ash (aref a (+ i 1)) 8) + (ash (aref a (+ i 2)) 16) + (ash (aref a (+ i 3)) 24)))) (define (ref-int16-LE a i) (int16 (+ (ash (aref a (+ i 0)) 0) - (ash (aref a (+ i 1)) 8)))) + (ash (aref a (+ i 1)) 8)))) (define (hex5 n) (string.lpad (number->string n 16) 5 #\0)) @@ -652,79 +656,79 @@ (define (disassemble f . lev?) (if (null? lev?) (begin (disassemble f 0) - (newline) - (return #t))) + (newline) + (return #t))) (let ((lev (car lev?)) - (code (function:code f)) - (vals (function:vals f))) + (code (function:code f)) + (vals (function:vals f))) (define (print-val v) (if (and (function? v) (not (builtin? v))) - (begin (princ "\n") - (disassemble v (+ lev 1))) - (print v))) + (begin (princ "\n") + (disassemble v (+ lev 1))) + (print v))) (dotimes (xx lev) (princ "\t")) (princ "maxstack " (ref-int32-LE code 0) "\n") (let ((i 4) - (N (length code))) + (N (length code))) (while (< i N) - ; find key whose value matches the current byte - (let ((inst (table.foldl (lambda (k v z) - (or z (and (eq? v (aref code i)) - k))) - #f Instructions))) - (if (> i 4) (newline)) - (dotimes (xx lev) (princ "\t")) - (princ (hex5 (- i 4)) ": " - (string inst) "\t") - (set! i (+ i 1)) - (case inst - ((loadv.l loadg.l setg.l) - (print-val (aref vals (ref-int32-LE code i))) - (set! i (+ i 4))) - - ((loadv loadg setg) - (print-val (aref vals (aref code i))) - (set! i (+ i 1))) - - ((loada seta call tcall list + - * / vector - argc vargc loadi8 apply tapply) - (princ (number->string (aref code i))) - (set! i (+ i 1))) - - ((loada.l seta.l largc lvargc call.l tcall.l) - (princ (number->string (ref-int32-LE code i))) - (set! i (+ i 4))) - - ((loadc setc) - (princ (number->string (aref code i)) " ") - (set! i (+ i 1)) - (princ (number->string (aref code i))) - (set! i (+ i 1))) - - ((loadc.l setc.l optargs keyargs) - (princ (number->string (ref-int32-LE code i)) " ") - (set! i (+ i 4)) - (princ (number->string (ref-int32-LE code i))) - (set! i (+ i 4)) - (if (eq? inst 'keyargs) - (begin - (princ " ") - (princ (number->string (ref-int32-LE code i)) " ") - (set! i (+ i 4))))) - - ((brbound) - (princ (number->string (ref-int32-LE code i)) " ") - (set! i (+ i 4))) - - ((jmp brf brt brne brnn brn) - (princ "@" (hex5 (+ i -4 (ref-int16-LE code i)))) - (set! i (+ i 2))) - - ((jmp.l brf.l brt.l brne.l brnn.l brn.l) - (princ "@" (hex5 (+ i -4 (ref-int32-LE code i)))) - (set! i (+ i 4))) - - (else #f))))))) + ; find key whose value matches the current byte + (let ((inst (table.foldl (lambda (k v z) + (or z (and (eq? v (aref code i)) + k))) + #f Instructions))) + (if (> i 4) (newline)) + (dotimes (xx lev) (princ "\t")) + (princ (hex5 (- i 4)) ": " + (string inst) "\t") + (set! i (+ i 1)) + (case inst + ((loadv.l loadg.l setg.l) + (print-val (aref vals (ref-int32-LE code i))) + (set! i (+ i 4))) + + ((loadv loadg setg) + (print-val (aref vals (aref code i))) + (set! i (+ i 1))) + + ((loada seta call tcall list + - * / vector + argc vargc loadi8 apply tapply) + (princ (number->string (aref code i))) + (set! i (+ i 1))) + + ((loada.l seta.l largc lvargc call.l tcall.l) + (princ (number->string (ref-int32-LE code i))) + (set! i (+ i 4))) + + ((loadc setc) + (princ (number->string (aref code i)) " ") + (set! i (+ i 1)) + (princ (number->string (aref code i))) + (set! i (+ i 1))) + + ((loadc.l setc.l optargs keyargs) + (princ (number->string (ref-int32-LE code i)) " ") + (set! i (+ i 4)) + (princ (number->string (ref-int32-LE code i))) + (set! i (+ i 4)) + (if (eq? inst 'keyargs) + (begin + (princ " ") + (princ (number->string (ref-int32-LE code i)) " ") + (set! i (+ i 4))))) + + ((brbound) + (princ (number->string (ref-int32-LE code i)) " ") + (set! i (+ i 4))) + + ((jmp brf brt brne brnn brn) + (princ "@" (hex5 (+ i -4 (ref-int16-LE code i)))) + (set! i (+ i 2))) + + ((jmp.l brf.l brt.l brne.l brnn.l brn.l) + (princ "@" (hex5 (+ i -4 (ref-int32-LE code i)))) + (set! i (+ i 4))) + + (else #f))))))) ; From SRFI 89 by Marc Feeley (http://srfi.schemers.org/srfi-89/srfi-89.html) ; Copyright (C) Marc Feeley 2006. All Rights Reserved. diff --git a/scheme-core/mkboot0.scm b/scheme-core/mkboot0.scm index f653ea3..73b76b2 100644 --- a/scheme-core/mkboot0.scm +++ b/scheme-core/mkboot0.scm @@ -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*)) diff --git a/scheme-core/system.scm b/scheme-core/system.scm index 883a07a..3da726e 100644 --- a/scheme-core/system.scm +++ b/scheme-core/system.scm @@ -34,21 +34,21 @@ (define-macro (define-macro form . body) `(set-syntax! ',(car form) - (lambda ,(cdr form) ,@body))) + (lambda ,(cdr form) ,@body))) #;(define (map1 f lst acc) (cdr (prog1 acc - (while (pair? lst) - (begin (set! acc - (cdr (set-cdr! acc (cons (f (car lst)) ())))) - (set! lst (cdr lst))))))) + (while (pair? lst) + (begin (set! acc + (cdr (set-cdr! acc (cons (f (car lst)) ())))) + (set! lst (cdr lst))))))) #;(define (mapn f lsts) (if (null? (car lsts)) () (cons (apply f (map1 car lsts (list ()))) - (mapn f (map1 cdr lsts (list ())))))) + (mapn f (map1 cdr lsts (list ())))))) #;(define (map f lst . lsts) (if (null? lsts) @@ -64,56 +64,56 @@ (define-macro (let binds . body) (let ((lname #f)) (if (symbol? binds) - (begin (set! lname binds) - (set! binds (car body)) - (set! body (cdr body)))) + (begin (set! lname binds) + (set! binds (car body)) + (set! body (cdr body)))) (let ((thelambda - `(lambda ,(map (lambda (c) (if (pair? c) (car c) c)) - binds) - ,@body)) - (theargs - (map (lambda (c) (if (pair? c) (cadr c) (void))) binds))) + `(lambda ,(map (lambda (c) (if (pair? c) (car c) c)) + binds) + ,@body)) + (theargs + (map (lambda (c) (if (pair? c) (cadr c) (void))) binds))) (cons (if lname - `(letrec ((,lname ,thelambda)) ,lname) - thelambda) - theargs)))) + `(letrec ((,lname ,thelambda)) ,lname) + thelambda) + theargs)))) (define-macro (cond . clauses) (define (cond-clauses->if lst) (if (atom? lst) - #f - (let ((clause (car lst))) - (if (or (eq? (car clause) 'else) - (eq? (car clause) #t)) - (if (null? (cdr clause)) - (car clause) - (cons 'begin (cdr clause))) - (if (null? (cdr clause)) - ; test by itself - (list 'or - (car clause) - (cond-clauses->if (cdr lst))) - ; test => expression - (if (eq? (cadr clause) '=>) - (if (1arg-lambda? (caddr clause)) - ; test => (lambda (x) ...) - (let ((var (caadr (caddr clause)))) - `(let ((,var ,(car clause))) - (if ,var ,(cons 'begin (cddr (caddr clause))) - ,(cond-clauses->if (cdr lst))))) - ; test => proc - (let ((b (gensym))) - `(let ((,b ,(car clause))) - (if ,b - (,(caddr clause) ,b) - ,(cond-clauses->if (cdr lst)))))) - (list 'if - (car clause) - (cons 'begin (cdr clause)) - (cond-clauses->if (cdr lst))))))))) + #f + (let ((clause (car lst))) + (if (or (eq? (car clause) 'else) + (eq? (car clause) #t)) + (if (null? (cdr clause)) + (car clause) + (cons 'begin (cdr clause))) + (if (null? (cdr clause)) + ; test by itself + (list 'or + (car clause) + (cond-clauses->if (cdr lst))) + ; test => expression + (if (eq? (cadr clause) '=>) + (if (1arg-lambda? (caddr clause)) + ; test => (lambda (x) ...) + (let ((var (caadr (caddr clause)))) + `(let ((,var ,(car clause))) + (if ,var ,(cons 'begin (cddr (caddr clause))) + ,(cond-clauses->if (cdr lst))))) + ; test => proc + (let ((b (gensym))) + `(let ((,b ,(car clause))) + (if ,b + (,(caddr clause) ,b) + ,(cond-clauses->if (cdr lst)))))) + (list 'if + (car clause) + (cons 'begin (cdr clause)) + (cond-clauses->if (cdr lst))))))))) (cond-clauses->if clauses)) -; standard procedures --------------------------------------------------------- +; standard procedures -------------------------------------------------------- (define (member item lst) (cond ((atom? lst) #f) @@ -126,12 +126,12 @@ (define (assoc item lst) (cond ((atom? lst) #f) - ((equal? (caar lst) item) (car lst)) - (#t (assoc item (cdr lst))))) + ((equal? (caar lst) item) (car lst)) + (#t (assoc item (cdr lst))))) (define (assv item lst) (cond ((atom? lst) #f) - ((eqv? (caar lst) item) (car lst)) - (#t (assv item (cdr lst))))) + ((eqv? (caar lst) item) (car lst)) + (#t (assv item (cdr lst))))) (define (> a b) (< b a)) (define (nan? x) (or (equal? x +nan.0) (equal? x -nan.0))) @@ -149,10 +149,10 @@ (define (1- n) (- n 1)) (define (mod0 x y) (- x (* (div0 x y) y))) (define (div x y) (+ (div0 x y) - (or (and (< x 0) - (or (and (< y 0) 1) - -1)) - 0))) + (or (and (< x 0) + (or (and (< y 0) 1) + -1)) + 0))) (define (mod x y) (- x (* (div x y) y))) (define (random n) (if (integer? n) @@ -167,8 +167,8 @@ (foldl (lambda (a b) (if (< a b) a b)) x0 xs))) (define (char? x) (eq? (typeof x) 'wchar)) (define (array? x) (or (vector? x) - (let ((t (typeof x))) - (and (pair? t) (eq? (car t) 'array))))) + (let ((t (typeof x))) + (and (pair? t) (eq? (car t) 'array))))) (define (closure? x) (and (function? x) (not (builtin? x)))) (define (caar x) (car (car x))) @@ -202,18 +202,18 @@ (let ((*values* (list '*values*))) (set! values - (lambda vs - (if (and (pair? vs) (null? (cdr vs))) - (car vs) - (cons *values* vs)))) + (lambda vs + (if (and (pair? vs) (null? (cdr vs))) + (car vs) + (cons *values* vs)))) (set! call-with-values - (lambda (producer consumer) - (let ((res (producer))) - (if (and (pair? res) (eq? *values* (car res))) - (apply consumer (cdr res)) - (consumer res)))))) + (lambda (producer consumer) + (let ((res (producer))) + (if (and (pair? res) (eq? *values* (car res))) + (apply consumer (cdr res)) + (consumer res)))))) -; list utilities -------------------------------------------------------------- +; list utilities ------------------------------------------------------------- (define (every pred lst) (or (atom? lst) @@ -234,7 +234,7 @@ (define (list-head lst n) (if (<= n 0) () (cons (car lst) - (list-head (cdr lst) (- n 1))))) + (list-head (cdr lst) (- n 1))))) (define (list-ref lst n) (car (list-tail lst n))) @@ -244,15 +244,15 @@ ; work and always terminates. (define (length= lst n) (cond ((< n 0) #f) - ((= n 0) (atom? lst)) - ((atom? lst) (= n 0)) - (else (length= (cdr lst) (- n 1))))) + ((= n 0) (atom? lst)) + ((atom? lst) (= n 0)) + (else (length= (cdr lst) (- n 1))))) (define (length> lst n) (cond ((< n 0) lst) - ((= n 0) (and (pair? lst) lst)) - ((atom? lst) (< n 0)) - (else (length> (cdr lst) (- n 1))))) + ((= n 0) (and (pair? lst) lst)) + ((atom? lst) (< n 0)) + (else (length> (cdr lst) (- n 1))))) (define (last-pair l) (if (atom? (cdr l)) @@ -266,48 +266,48 @@ (define (to-proper l) (cond ((null? l) l) - ((atom? l) (list l)) - (else (cons (car l) (to-proper (cdr l)))))) + ((atom? l) (list l)) + (else (cons (car l) (to-proper (cdr l)))))) (define (map! f lst) (prog1 lst - (while (pair? lst) - (set-car! lst (f (car lst))) - (set! lst (cdr lst))))) + (while (pair? lst) + (set-car! lst (f (car lst))) + (set! lst (cdr lst))))) (define (filter pred lst) (define (filter- f lst acc) (cdr (prog1 acc (while (pair? lst) - (begin (if (pred (car lst)) - (set! acc - (cdr (set-cdr! acc (cons (car lst) ()))))) - (set! lst (cdr lst))))))) + (begin (if (pred (car lst)) + (set! acc + (cdr (set-cdr! acc (cons (car lst) ()))))) + (set! lst (cdr lst))))))) (filter- pred lst (list ()))) (define (separate pred lst) (define (separate- pred lst yes no) (let ((vals - (prog1 - (cons yes no) - (while (pair? lst) - (begin (if (pred (car lst)) - (set! yes - (cdr (set-cdr! yes (cons (car lst) ())))) - (set! no - (cdr (set-cdr! no (cons (car lst) ()))))) - (set! lst (cdr lst))))))) + (prog1 + (cons yes no) + (while (pair? lst) + (begin (if (pred (car lst)) + (set! yes + (cdr (set-cdr! yes (cons (car lst) ())))) + (set! no + (cdr (set-cdr! no (cons (car lst) ()))))) + (set! lst (cdr lst))))))) (values (cdr (car vals)) (cdr (cdr vals))))) (separate- pred lst (list ()) (list ()))) (define (count f l) (define (count- f l n) (if (null? l) - n - (count- f (cdr l) (if (f (car l)) - (+ n 1) - n)))) + n + (count- f (cdr l) (if (f (car l)) + (+ n 1) + n)))) (count- f l 0)) (define (nestlist f zero n) @@ -330,9 +330,9 @@ (define (reverse!- prev l) (while (pair? l) - (set! l (prog1 (cdr l) - (set-cdr! l (prog1 prev - (set! prev l)))))) + (set! l (prog1 (cdr l) + (set-cdr! l (prog1 prev + (set! prev l)))))) prev) (define (reverse! l) (reverse!- () l)) @@ -345,24 +345,24 @@ (define (delete-duplicates lst) (if (length> lst 20) (let ((t (table))) - (let loop ((l lst) (acc '())) - (if (atom? l) - (reverse! acc) - (if (has? t (car l)) - (loop (cdr l) acc) - (begin - (put! t (car l) #t) - (loop (cdr l) (cons (car l) acc))))))) + (let loop ((l lst) (acc '())) + (if (atom? l) + (reverse! acc) + (if (has? t (car l)) + (loop (cdr l) acc) + (begin + (put! t (car l) #t) + (loop (cdr l) (cons (car l) acc))))))) (if (atom? lst) - lst - (let ((elt (car lst)) - (tail (cdr lst))) - (if (member elt tail) - (delete-duplicates tail) - (cons elt - (delete-duplicates tail))))))) + lst + (let ((elt (car lst)) + (tail (cdr lst))) + (if (member elt tail) + (delete-duplicates tail) + (cons elt + (delete-duplicates tail))))))) -; backquote ------------------------------------------------------------------- +; backquote ------------------------------------------------------------------ (define (revappend l1 l2) (reverse- l2 l1)) (define (nreconc l1 l2) (reverse!- l2 l1)) @@ -371,89 +371,89 @@ (or (and (atom? x) (not (symbol? x))) (and (constant? x) - (symbol? x) + (symbol? x) (eq x (top-level-value x))))) (define-macro (quasiquote x) (bq-process x 0)) (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? (car x) 'unquote-nsplicing) + (and (eq? (car x) 'unquote) + (length> x 2)))) (eq? x 'unquote))) ;; bracket without splicing (define (bq-bracket1 x d) (if (and (pair? x) (eq? (car x) 'unquote)) (if (= d 0) - (cadr x) - (list cons ''unquote - (bq-process (cdr x) (- d 1)))) + (cadr x) + (list cons ''unquote + (bq-process (cdr x) (- d 1)))) (bq-process x d))) (define (bq-bracket x d) (cond ((atom? x) (list list (bq-process x d))) - ((eq? (car x) 'unquote) - (if (= d 0) - (cons list (cdr x)) - (list list (list cons ''unquote - (bq-process (cdr x) (- d 1)))))) - ((eq? (car x) 'unquote-splicing) - (if (= d 0) - (list 'copy-list (cadr x)) - (list list (list list ''unquote-splicing - (bq-process (cadr x) (- d 1)))))) - ((eq? (car x) 'unquote-nsplicing) - (if (= d 0) - (cadr x) - (list list (list list ''unquote-nsplicing - (bq-process (cadr x) (- d 1)))))) - (else (list list (bq-process x d))))) + ((eq? (car x) 'unquote) + (if (= d 0) + (cons list (cdr x)) + (list list (list cons ''unquote + (bq-process (cdr x) (- d 1)))))) + ((eq? (car x) 'unquote-splicing) + (if (= d 0) + (list 'copy-list (cadr x)) + (list list (list list ''unquote-splicing + (bq-process (cadr x) (- d 1)))))) + ((eq? (car x) 'unquote-nsplicing) + (if (= d 0) + (cadr x) + (list list (list list ''unquote-nsplicing + (bq-process (cadr x) (- d 1)))))) + (else (list list (bq-process x d))))) (define (bq-process x d) (cond ((symbol? x) (list 'quote x)) - ((vector? x) - (let ((body (bq-process (vector->list x) d))) - (if (eq? (car body) list) - (cons vector (cdr body)) - (list apply vector body)))) + ((vector? x) + (let ((body (bq-process (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-process (cadr x) (+ d 1)))) + (list list ''quasiquote (bq-process (cadr x) (+ d 1)))) ((eq? (car x) 'unquote) - (if (and (= d 0) (length= x 2)) - (cadr x) - (list cons ''unquote (bq-process (cdr x) (- d 1))))) - ((not (any splice-form? x)) + (if (and (= d 0) (length= x 2)) + (cadr x) + (list cons ''unquote (bq-process (cdr x) (- d 1))))) + ((not (any splice-form? x)) (let ((lc (lastcdr x)) (forms (map (lambda (x) (bq-bracket1 x d)) x))) (if (null? lc) (cons list forms) - (if (null? (cdr forms)) - (list cons (car forms) (bq-process lc d)) - (nconc (cons list* forms) (list (bq-process 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-process (cdr p) - (- d 1))))))) - (else - (loop (cdr p) (cons (bq-bracket (car p) d) q))))) - (else - ;; (... . x) - (cons 'nconc (reverse! (cons (bq-process p d) q))))))))) + (if (null? (cdr forms)) + (list cons (car forms) (bq-process lc d)) + (nconc (cons list* forms) (list (bq-process 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-process (cdr p) + (- d 1))))))) + (else + (loop (cdr p) (cons (bq-bracket (car p) d) q))))) + (else + ;; (... . x) + (cons 'nconc (reverse! (cons (bq-process p d) q))))))))) -; standard macros ------------------------------------------------------------- +; standard macros ------------------------------------------------------------ (define (quote-value v) (if (self-evaluating? v) @@ -463,10 +463,10 @@ (define-macro (let* binds . body) (if (atom? binds) `((lambda () ,@body)) `((lambda (,(caar binds)) - ,@(if (pair? (cdr binds)) - `((let* ,(cdr binds) ,@body)) - body)) - ,(cadar binds)))) + ,@(if (pair? (cdr binds)) + `((let* ,(cdr binds) ,@body)) + body)) + ,(cadar binds)))) (define-macro (when c . body) (list 'if c (cons 'begin body) #f)) (define-macro (unless c . body) (list 'if c #f (cons 'begin body))) @@ -474,37 +474,37 @@ (define-macro (case key . clauses) (define (vals->cond key v) (cond ((eq? v 'else) 'else) - ((null? v) #f) - ((symbol? v) `(eq? ,key ,(quote-value v))) + ((null? v) #f) + ((symbol? v) `(eq? ,key ,(quote-value v))) ((atom? v) `(eqv? ,key ,(quote-value v))) - ((null? (cdr v)) `(eqv? ,key ,(quote-value (car v)))) - ((every symbol? v) - `(memq ,key ',v)) - (else `(memv ,key ',v)))) + ((null? (cdr v)) `(eqv? ,key ,(quote-value (car v)))) + ((every symbol? v) + `(memq ,key ',v)) + (else `(memv ,key ',v)))) (let ((g (gensym))) `(let ((,g ,key)) (cond ,.(map (lambda (clause) - (cons (vals->cond g (car clause)) - (cdr clause))) - clauses))))) + (cons (vals->cond g (car clause)) + (cdr clause))) + clauses))))) (define-macro (do vars test-spec . commands) (let ((loop (gensym)) - (test-expr (car test-spec)) - (vars (map car vars)) - (inits (map cadr vars)) - (steps (map (lambda (x) - (if (pair? (cddr x)) - (caddr x) - (car x))) - vars))) + (test-expr (car test-spec)) + (vars (map car vars)) + (inits (map cadr vars)) + (steps (map (lambda (x) + (if (pair? (cddr x)) + (caddr x) + (car x))) + vars))) `(letrec ((,loop (lambda ,vars - (if ,test-expr - (begin - ,@(cdr test-spec)) - (begin - ,@commands - (,loop ,.steps)))))) + (if ,test-expr + (begin + ,@(cdr test-spec)) + (begin + ,@commands + (,loop ,.steps)))))) (,loop ,.inits)))) ; SRFI 8 @@ -535,26 +535,26 @@ (define (for-each f l . lsts) (define (for-each-n f lsts) (if (pair? (car lsts)) - (begin (apply f (map car lsts)) - (for-each-n f (map cdr lsts))))) + (begin (apply f (map car lsts)) + (for-each-n f (map cdr lsts))))) (if (null? lsts) (while (pair? l) - (begin (f (car l)) - (set! l (cdr l)))) + (begin (f (car l)) + (set! l (cdr l)))) (for-each-n f (cons l lsts))) #t) (define-macro (with-bindings binds . body) (let ((vars (map car binds)) - (vals (map cadr binds)) - (olds (map (lambda (x) (gensym)) binds))) + (vals (map cadr binds)) + (olds (map (lambda (x) (gensym)) binds))) `(let ,(map list olds vars) ,@(map (lambda (v val) `(set! ,v ,val)) vars vals) (unwind-protect - (begin ,@body) - (begin ,@(map (lambda (v old) `(set! ,v ,old)) vars olds)))))) + (begin ,@body) + (begin ,@(map (lambda (v old) `(set! ,v ,old)) vars olds)))))) -; exceptions ------------------------------------------------------------------ +; exceptions ----------------------------------------------------------------- (define (error . args) (raise (cons 'error args))) @@ -566,60 +566,60 @@ (eq (car ,e) 'thrown-value) (eq (cadr ,e) ,tag)) (caddr ,e) - (raise ,e)))))) + (raise ,e)))))) (define-macro (unwind-protect expr finally) (let ((e (gensym)) - (thk (gensym))) + (thk (gensym))) `(let ((,thk (lambda () ,finally))) (prog1 (trycatch ,expr - (lambda (,e) (begin (,thk) (raise ,e)))) - (,thk))))) + (lambda (,e) (begin (,thk) (raise ,e)))) + (,thk))))) -; debugging utilities --------------------------------------------------------- +; debugging utilities -------------------------------------------------------- (define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr)))) (define traced? (letrec ((sample-traced-lambda (lambda args (begin (write (cons 'x args)) - (newline) - (apply #.apply args))))) + (newline) + (apply #.apply args))))) (lambda (f) (and (closure? f) - (equal? (function:code f) - (function:code sample-traced-lambda)))))) + (equal? (function:code f) + (function:code sample-traced-lambda)))))) (define (trace sym) (let* ((func (top-level-value sym)) - (args (gensym))) + (args (gensym))) (if (not (traced? func)) - (set-top-level-value! sym - (eval - `(lambda ,args - (begin (write (cons ',sym ,args)) - (newline) - (apply ',func ,args))))))) + (set-top-level-value! sym + (eval + `(lambda ,args + (begin (write (cons ',sym ,args)) + (newline) + (apply ',func ,args))))))) 'ok) (define (untrace sym) (let ((func (top-level-value sym))) (if (traced? func) - (set-top-level-value! sym - (aref (function:vals func) 2))))) + (set-top-level-value! sym + (aref (function:vals func) 2))))) (define-macro (time expr) (let ((t0 (gensym))) `(let ((,t0 (time.now))) (prog1 - ,expr - (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n"))))) + ,expr + (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n"))))) -; text I/O -------------------------------------------------------------------- +; text I/O ------------------------------------------------------------------- (define (print . args) (for-each write args)) (define (princ . args) (with-bindings ((*print-readably* #f)) - (for-each write args))) + (for-each write args))) (define (newline (port *output-stream*)) (io.write port *linefeed*) @@ -630,10 +630,10 @@ ; call f on a stream until the stream runs out of data (define (read-all-of f s) (let loop ((lines ()) - (curr (f s))) + (curr (f s))) (if (io.eof? s) - (reverse! lines) - (loop (cons curr lines) (f s))))) + (reverse! lines) + (loop (cons curr lines) (f s))))) (define (io.readlines s) (read-all-of io.readline s)) (define (read-all s) (read-all-of read s)) @@ -643,17 +643,17 @@ (io.copy b s) (let ((str (io.tostring! b))) (if (and (equal? str "") (io.eof? s)) - (eof-object) - str)))) + (eof-object) + str)))) (define-macro (with-output-to stream . body) `(with-bindings ((*output-stream* ,stream)) - ,@body)) + ,@body)) (define-macro (with-input-from stream . body) `(with-bindings ((*input-stream* ,stream)) - ,@body)) + ,@body)) -; vector functions ------------------------------------------------------------ +; vector functions ----------------------------------------------------------- (define (list->vector l) (apply vector l)) (define (vector->list v) @@ -672,7 +672,7 @@ (aset! nv i (f (aref v i))))) nv)) -; table functions ------------------------------------------------------------- +; table functions ------------------------------------------------------------ (define (table.pairs t) (table.foldl (lambda (k v z) (cons (cons k v) z)) @@ -691,53 +691,53 @@ (define (table.invert t) (let ((nt (table))) (table.foldl (lambda (k v z) (put! nt v k)) - () t) + () t) nt)) (define (table.foreach f 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 *whitespace* (string.encode #array(wchar 9 10 11 12 13 32 133 160 5760 6158 8192 - 8193 8194 8195 8196 8197 8198 8199 8200 - 8201 8202 8232 8233 8239 8287 12288))) + 8193 8194 8195 8196 8197 8198 8199 8200 + 8201 8202 8232 8233 8239 8287 12288))) (define (string.trim s at-start at-end) (define (trim-start s chars i L) (if (and (< i L) - (string.find chars (string.char s i))) - (trim-start s chars (string.inc s i) L) - i)) + (string.find chars (string.char s i))) + (trim-start s chars (string.inc s i) L) + i)) (define (trim-end s chars i) (if (and (> i 0) - (string.find chars (string.char s (string.dec s i)))) - (trim-end s chars (string.dec s i)) - i)) + (string.find chars (string.char s (string.dec s i)))) + (trim-end s chars (string.dec s i)) + i)) (let ((L (length s))) (string.sub s - (trim-start s at-start 0 L) - (trim-end s at-end L)))) + (trim-start s at-start 0 L) + (trim-end s at-end L)))) (define (string.map f s) (let ((b (buffer)) - (n (length s))) + (n (length s))) (let ((i 0)) (while (< i n) - (begin (io.putc b (f (string.char s i))) - (set! i (string.inc s i))))) + (begin (io.putc b (f (string.char s i))) + (set! i (string.inc s i))))) (io.tostring! b))) (define (string.rep s k) (cond ((< k 4) - (cond ((<= k 0) "") - ((= k 1) (string s)) - ((= k 2) (string s s)) - (else (string s s s)))) - ((odd? k) (string s (string.rep s (- k 1)))) - (else (string.rep (string s s) (/ k 2))))) + (cond ((<= k 0) "") + ((= k 1) (string s)) + ((= k 2) (string s s)) + (else (string s s s)))) + ((odd? k) (string s (string.rep s (- k 1)))) + (else (string.rep (string s s) (/ k 2))))) (define (string.lpad s n c) (string (string.rep c (- n (string.count s))) s)) (define (string.rpad s n c) (string s (string.rep c (- n (string.count s))))) @@ -750,149 +750,149 @@ (define (string.join strlist sep) (if (null? strlist) "" (let ((b (buffer))) - (io.write b (car strlist)) - (for-each (lambda (s) (begin (io.write b sep) - (io.write b s))) - (cdr strlist)) - (io.tostring! b)))) + (io.write b (car strlist)) + (for-each (lambda (s) (begin (io.write b sep) + (io.write b s))) + (cdr strlist)) + (io.tostring! b)))) -; toplevel -------------------------------------------------------------------- +; toplevel ------------------------------------------------------------------- (define (macrocall? e) (and (symbol? (car e)) - (symbol-syntax (car e)))) + (symbol-syntax (car e)))) (define (macroexpand-1 e) (if (atom? e) e (let ((f (macrocall? e))) - (if f (apply f (cdr e)) - e)))) + (if f (apply f (cdr e)) + e)))) (define (expand e) ; symbol resolves to toplevel; i.e. has no shadowing definition (define (top? s env) (not (or (bound? s) (assq s env)))) - + (define (splice-begin body) (cond ((atom? body) body) - ((equal? body '((begin))) - body) - ((and (pair? (car body)) - (eq? (caar body) 'begin)) - (append (splice-begin (cdar body)) (splice-begin (cdr body)))) - (else - (cons (car body) (splice-begin (cdr body)))))) - + ((equal? body '((begin))) + body) + ((and (pair? (car body)) + (eq? (caar body) 'begin)) + (append (splice-begin (cdar body)) (splice-begin (cdr body)))) + (else + (cons (car body) (splice-begin (cdr body)))))) + (define *expanded* (list '*expanded*)) - + (define (expand-body body env) (if (atom? body) body - (let* ((body (if (top? 'begin env) - (splice-begin body) - body)) - (def? (top? 'define env)) - (dvars (if def? (get-defined-vars body) ())) - (env (nconc (map list dvars) env))) - (if (not def?) - (map (lambda (x) (expand-in x env)) body) - (let* ((ex-nondefs ; expand non-definitions - (let loop ((body body)) - (cond ((atom? body) body) - ((and (pair? (car body)) - (eq? 'define (caar body))) - (cons (car body) (loop (cdr body)))) - (else - (let ((form (expand-in (car body) env))) - (set! env (nconc - (map list (get-defined-vars form)) - env)) - (cons - (cons *expanded* form) - (loop (cdr body)))))))) - (body ex-nondefs)) - (while (pair? body) ; now expand deferred definitions - (if (not (eq? *expanded* (caar body))) - (set-car! body (expand-in (car body) env)) - (set-car! body (cdar body))) - (set! body (cdr body))) - ex-nondefs))))) - + (let* ((body (if (top? 'begin env) + (splice-begin body) + body)) + (def? (top? 'define env)) + (dvars (if def? (get-defined-vars body) ())) + (env (nconc (map list dvars) env))) + (if (not def?) + (map (lambda (x) (expand-in x env)) body) + (let* ((ex-nondefs ; expand non-definitions + (let loop ((body body)) + (cond ((atom? body) body) + ((and (pair? (car body)) + (eq? 'define (caar body))) + (cons (car body) (loop (cdr body)))) + (else + (let ((form (expand-in (car body) env))) + (set! env (nconc + (map list (get-defined-vars form)) + env)) + (cons + (cons *expanded* form) + (loop (cdr body)))))))) + (body ex-nondefs)) + (while (pair? body) ; now expand deferred definitions + (if (not (eq? *expanded* (caar body))) + (set-car! body (expand-in (car body) env)) + (set-car! body (cdar body))) + (set! body (cdr body))) + ex-nondefs))))) + (define (expand-lambda-list l env) (if (atom? l) l - (cons (if (and (pair? (car l)) (pair? (cdr (car l)))) - (list (caar l) (expand-in (cadar l) env)) - (car l)) - (expand-lambda-list (cdr l) env)))) - + (cons (if (and (pair? (car l)) (pair? (cdr (car l)))) + (list (caar l) (expand-in (cadar l) env)) + (car l)) + (expand-lambda-list (cdr l) env)))) + (define (l-vars l) (cond ((atom? l) (list l)) - ((pair? (car l)) (cons (caar l) (l-vars (cdr l)))) - (else (cons (car l) (l-vars (cdr l)))))) - + ((pair? (car l)) (cons (caar l) (l-vars (cdr l)))) + (else (cons (car l) (l-vars (cdr l)))))) + (define (expand-lambda e env) (let ((formals (cadr e)) - (name (lastcdr e)) - (body (cddr e)) - (vars (l-vars (cadr e)))) + (name (lastcdr e)) + (body (cddr e)) + (vars (l-vars (cadr e)))) (let ((env (nconc (map list vars) env))) - `(lambda ,(expand-lambda-list formals env) - ,.(expand-body body env) - . ,name)))) - + `(lambda ,(expand-lambda-list formals env) + ,.(expand-body body env) + . ,name)))) + (define (expand-define e env) (if (or (null? (cdr e)) (atom? (cadr e))) - (if (null? (cddr e)) - e - `(define ,(cadr e) ,(expand-in (caddr e) env))) - (let ((formals (cdadr e)) - (name (caadr e)) - (body (cddr e)) - (vars (l-vars (cdadr e)))) - (let ((env (nconc (map list vars) env))) - `(define ,(cons name (expand-lambda-list formals env)) - ,.(expand-body body env)))))) - + (if (null? (cddr e)) + e + `(define ,(cadr e) ,(expand-in (caddr e) env))) + (let ((formals (cdadr e)) + (name (caadr e)) + (body (cddr e)) + (vars (l-vars (cdadr e)))) + (let ((env (nconc (map list vars) env))) + `(define ,(cons name (expand-lambda-list formals env)) + ,.(expand-body body env)))))) + (define (expand-let-syntax e env) (let ((binds (cadr e))) (cons 'begin - (expand-body (cddr e) - (nconc - (map (lambda (bind) - (list (car bind) - ((compile-thunk - (expand-in (cadr bind) env))) - env)) - binds) - env))))) - + (expand-body (cddr e) + (nconc + (map (lambda (bind) + (list (car bind) + ((compile-thunk + (expand-in (cadr bind) env))) + env)) + binds) + env))))) + ; given let-syntax definition environment (menv) and environment ; at the point of the macro use (lenv), return the environment to ; expand the macro use in. TODO (define (local-expansion-env menv lenv) menv) - + (define (expand-in e env) (if (atom? e) e - (let* ((head (car e)) - (bnd (assq head env)) - (default (lambda () - (let loop ((e e)) - (if (atom? e) e - (cons (if (atom? (car e)) - (car e) - (expand-in (car e) env)) - (loop (cdr e)))))))) - (cond ((and bnd (pair? (cdr bnd))) ; local macro - (expand-in (apply (cadr bnd) (cdr e)) - (local-expansion-env (caddr bnd) env))) - ((or bnd ; bound lexical or toplevel var - (not (symbol? head)) - (bound? head)) - (default)) - ((macrocall? e) => (lambda (f) - (expand-in (apply f (cdr e)) env))) - ((eq? head 'quote) e) - ((eq? head 'lambda) (expand-lambda e env)) - ((eq? head 'define) (expand-define e env)) - ((eq? head 'let-syntax) (expand-let-syntax e env)) - (else (default)))))) + (let* ((head (car e)) + (bnd (assq head env)) + (default (lambda () + (let loop ((e e)) + (if (atom? e) e + (cons (if (atom? (car e)) + (car e) + (expand-in (car e) env)) + (loop (cdr e)))))))) + (cond ((and bnd (pair? (cdr bnd))) ; local macro + (expand-in (apply (cadr bnd) (cdr e)) + (local-expansion-env (caddr bnd) env))) + ((or bnd ; bound lexical or toplevel var + (not (symbol? head)) + (bound? head)) + (default)) + ((macrocall? e) => (lambda (f) + (expand-in (apply f (cdr e)) env))) + ((eq? head 'quote) e) + ((eq? head 'lambda) (expand-lambda e env)) + ((eq? head 'define) (expand-define e env)) + ((eq? head 'let-syntax) (expand-let-syntax e env)) + (else (default)))))) (expand-in e ())) (define (eval x) ((compile-thunk (expand x)))) @@ -904,22 +904,22 @@ (trycatch (let next (prev E v) (if (not (io.eof? F)) - (next (read F) + (next (read F) prev - (load-process E)) - (begin (io.close F) - ; evaluate last form in almost-tail position - (load-process E)))) + (load-process E)) + (begin (io.close F) + ; evaluate last form in almost-tail position + (load-process E)))) (lambda (e) (begin - (io.close F) - (raise `(load-error ,filename ,e))))))) + (io.close F) + (raise `(load-error ,filename ,e))))))) (define *banner* (string.tail " ; _ ; |_ _ _ |_ _ | . _ _ ; | (-||||_(_)|__|_)|_) -;-------------------|---------------------------------------------------------- +;-------------------|-- " 1)) @@ -927,159 +927,159 @@ (define (prompt) (princ "> ") (io.flush *output-stream*) (let ((v (trycatch (read) - (lambda (e) (begin (io.discardbuffer *input-stream*) - (raise e)))))) + (lambda (e) (begin (io.discardbuffer *input-stream*) + (raise e)))))) (and (not (io.eof? *input-stream*)) - (let ((V (load-process v))) - (print V) - (set! that V) - #t)))) + (let ((V (load-process v))) + (print V) + (set! that V) + #t)))) (define (reploop) (when (trycatch (and (prompt) (newline)) - (lambda (e) - (top-level-exception-handler e) - #t)) - (begin (newline) - (reploop)))) + (lambda (e) + (top-level-exception-handler e) + #t)) + (begin (newline) + (reploop)))) (reploop) (newline)) (define (top-level-exception-handler e) (with-output-to *stderr* - (print-exception e) - (print-stack-trace (stacktrace)))) + (print-exception e) + (print-stack-trace (stacktrace)))) (define (print-stack-trace st) (define (find-in-f f tgt path) (let ((path (cons (function:name f) path))) (if (eq? (function:code f) (function:code tgt)) - (throw 'ffound path) - (let ((v (function:vals f))) - (for 0 (1- (length v)) - (lambda (i) (if (closure? (aref v i)) - (find-in-f (aref v i) tgt path)))))))) + (throw 'ffound path) + (let ((v (function:vals f))) + (for 0 (1- (length v)) + (lambda (i) (if (closure? (aref v i)) + (find-in-f (aref v i) tgt path)))))))) (define (fn-name f e) (let ((p (catch 'ffound - (begin - (for-each (lambda (topfun) - (find-in-f topfun f ())) - e) - #f)))) + (begin + (for-each (lambda (topfun) + (find-in-f topfun f ())) + e) + #f)))) (if p - (symbol (string.join (map string (reverse! p)) "/")) - 'lambda))) + (symbol (string.join (map string (reverse! p)) "/")) + 'lambda))) (let ((st (reverse! (list-tail st (if *interactive* 5 4)))) - (e (filter closure? (map (lambda (s) (and (bound? s) - (top-level-value s))) - (environment)))) - (n 0)) + (e (filter closure? (map (lambda (s) (and (bound? s) + (top-level-value s))) + (environment)))) + (n 0)) (for-each (lambda (f) (princ "#" n " ") (print (cons (fn-name (aref f 0) e) - (cdr (vector->list f)))) + (cdr (vector->list f)))) (newline) (set! n (+ n 1))) st))) (define (print-exception e) (cond ((and (pair? e) - (eq? (car e) 'type-error) - (length= e 4)) - (princ "type error: " (cadr e) ": expected " (caddr e) ", got ") - (print (cadddr e))) + (eq? (car e) 'type-error) + (length= e 4)) + (princ "type error: " (cadr e) ": expected " (caddr e) ", got ") + (print (cadddr e))) - ((and (pair? e) - (eq? (car e) 'bounds-error) - (length= e 4)) - (princ (cadr e) ": index " (cadddr e) " out of bounds for ") - (print (caddr e))) + ((and (pair? e) + (eq? (car e) 'bounds-error) + (length= e 4)) + (princ (cadr e) ": index " (cadddr e) " out of bounds for ") + (print (caddr e))) - ((and (pair? e) - (eq? (car e) 'unbound-error) - (pair? (cdr e))) - (princ "eval: variable " (cadr e) " has no value")) + ((and (pair? e) + (eq? (car e) 'unbound-error) + (pair? (cdr e))) + (princ "eval: variable " (cadr e) " has no value")) - ((and (pair? e) - (eq? (car e) 'error)) - (princ "error: ") - (apply princ (cdr e))) + ((and (pair? e) + (eq? (car e) 'error)) + (princ "error: ") + (apply princ (cdr e))) - ((and (pair? e) - (eq? (car e) 'load-error)) - (print-exception (caddr e)) - (princ "in file " (cadr e))) + ((and (pair? e) + (eq? (car e) 'load-error)) + (print-exception (caddr e)) + (princ "in file " (cadr e))) - ((and (list? e) - (length= e 2)) - (print (car e)) - (princ ": ") - (let ((msg (cadr e))) - ((if (or (string? msg) (symbol? msg)) - princ print) - msg))) + ((and (list? e) + (length= e 2)) + (print (car e)) + (princ ": ") + (let ((msg (cadr e))) + ((if (or (string? msg) (symbol? msg)) + princ print) + msg))) - (else (princ "*** Unhandled exception: ") - (print e))) + (else (princ "*** Unhandled exception: ") + (print e))) (princ *linefeed*)) (define (simple-sort l) (if (or (null? l) (null? (cdr l))) l (let ((piv (car l))) - (receive (less grtr) - (separate (lambda (x) (< x piv)) (cdr l)) - (nconc (simple-sort less) - (list piv) - (simple-sort grtr)))))) + (receive (less grtr) + (separate (lambda (x) (< x piv)) (cdr l)) + (nconc (simple-sort less) + (list piv) + (simple-sort grtr)))))) (define (make-system-image fname) (let ((f (file fname :write :create :truncate)) - (excludes '(*linefeed* *directory-separator* *argv* that - *print-pretty* *print-width* *print-readably* - *print-level* *print-length* *os-name*))) + (excludes '(*linefeed* *directory-separator* *argv* that + *print-pretty* *print-width* *print-readably* + *print-level* *print-length* *os-name*))) (with-bindings ((*print-pretty* #t) - (*print-readably* #t)) + (*print-readably* #t)) (let ((syms - (filter (lambda (s) - (and (bound? s) - (not (constant? s)) - (or (not (builtin? (top-level-value s))) - (not (equal? (string s) ; alias of builtin - (string (top-level-value s))))) - (not (memq s excludes)) - (not (iostream? (top-level-value s))))) - (simple-sort (environment))))) - (write (apply nconc (map list syms (map top-level-value syms))) f) - (io.write f *linefeed*)) + (filter (lambda (s) + (and (bound? s) + (not (constant? s)) + (or (not (builtin? (top-level-value s))) + (not (equal? (string s) ; alias of builtin + (string (top-level-value s))))) + (not (memq s excludes)) + (not (iostream? (top-level-value s))))) + (simple-sort (environment))))) + (write (apply nconc (map list syms (map top-level-value syms))) f) + (io.write f *linefeed*)) (io.close f)))) ; initialize globals that need to be set at load time (define (__init_globals) (if (or (eq? *os-name* 'win32) - (eq? *os-name* 'win64) - (eq? *os-name* 'windows)) + (eq? *os-name* 'win64) + (eq? *os-name* 'windows)) (begin (set! *directory-separator* "\\") - (set! *linefeed* "\r\n")) + (set! *linefeed* "\r\n")) (begin (set! *directory-separator* "/") - (set! *linefeed* "\n"))) + (set! *linefeed* "\n"))) (set! *output-stream* *stdout*) (set! *input-stream* *stdin*) (set! *error-stream* *stderr*)) (define (__script fname) (trycatch (load fname) - (lambda (e) (begin (top-level-exception-handler e) - (exit 1))))) + (lambda (e) (begin (top-level-exception-handler e) + (exit 1))))) (define (__start argv) (__init_globals) (if (pair? (cdr argv)) (begin (set! *argv* (cdr argv)) - (set! *interactive* #f) - (__script (cadr argv))) + (set! *interactive* #f) + (__script (cadr argv))) (begin (set! *argv* argv) - (set! *interactive* #t) - (princ *banner*) - (repl))) + (set! *interactive* #t) + (princ *banner*) + (repl))) (exit 0)) diff --git a/scheme-examples/bq.scm b/scheme-examples/bq.scm index 806e80a..ac08ac3 100644 --- a/scheme-examples/bq.scm +++ b/scheme-examples/bq.scm @@ -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 diff --git a/scheme-examples/cps.scm b/scheme-examples/cps.scm index ce01107..718522e 100644 --- a/scheme-examples/cps.scm +++ b/scheme-examples/cps.scm @@ -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 diff --git a/scheme-examples/rule30.scm b/scheme-examples/rule30.scm index 9d5b7ae..083e78e 100644 --- a/scheme-examples/rule30.scm +++ b/scheme-examples/rule30.scm @@ -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)) diff --git a/scheme-lib/lazy.scm b/scheme-lib/lazy.scm index c622a58..226a181 100644 --- a/scheme-lib/lazy.scm +++ b/scheme-lib/lazy.scm @@ -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. diff --git a/scheme-lib/psyntax.scm b/scheme-lib/psyntax.scm index 62f5125..67ee628 100644 --- a/scheme-lib/psyntax.scm +++ b/scheme-lib/psyntax.scm @@ -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)))))))) - diff --git a/scheme-lib/sort.scm b/scheme-lib/sort.scm index ed7b9cc..e25ee94 100644 --- a/scheme-lib/sort.scm +++ b/scheme-lib/sort.scm @@ -24,23 +24,23 @@ (define (sorted? seq less? . opt-key) (define key (if (null? opt-key) identity (car opt-key))) (cond ((null? seq) #t) - ((array? seq) - (let ((dimax (+ -1 (car (array-dimensions seq))))) - (or (<= dimax 1) - (let loop ((idx (+ -1 dimax)) - (last (key (array-ref seq dimax)))) - (or (negative? idx) - (let ((nxt (key (array-ref seq idx)))) - (and (less? nxt last) - (loop (+ -1 idx) nxt)))))))) - ((null? (cdr seq)) #t) - (else - (let loop ((last (key (car seq))) - (next (cdr seq))) - (or (null? next) - (let ((nxt (key (car next)))) - (and (not (less? nxt last)) - (loop nxt (cdr next))))))))) + ((array? seq) + (let ((dimax (+ -1 (car (array-dimensions seq))))) + (or (<= dimax 1) + (let loop ((idx (+ -1 dimax)) + (last (key (array-ref seq dimax)))) + (or (negative? idx) + (let ((nxt (key (array-ref seq idx)))) + (and (less? nxt last) + (loop (+ -1 idx) nxt)))))))) + ((null? (cdr seq)) #t) + (else + (let loop ((last (key (car seq))) + (next (cdr seq))) + (or (null? next) + (let ((nxt (key (car next)))) + (and (not (less? nxt last)) + (loop nxt (cdr next))))))))) ;;; (merge a b less?) ;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?) @@ -51,49 +51,49 @@ (define (merge a b less? . opt-key) (define key (if (null? opt-key) identity (car opt-key))) (cond ((null? a) b) - ((null? b) a) - (else - (let loop ((x (car a)) (kx (key (car a))) (a (cdr a)) - (y (car b)) (ky (key (car b))) (b (cdr b))) - ;; The loop handles the merging of non-empty lists. It has - ;; been written this way to save testing and car/cdring. - (if (less? ky kx) - (if (null? b) - (cons y (cons x a)) - (cons y (loop x kx a (car b) (key (car b)) (cdr b)))) - ;; x <= y - (if (null? a) - (cons x (cons y b)) - (cons x (loop (car a) (key (car a)) (cdr a) y ky b)))))))) + ((null? b) a) + (else + (let loop ((x (car a)) (kx (key (car a))) (a (cdr a)) + (y (car b)) (ky (key (car b))) (b (cdr b))) + ;; The loop handles the merging of non-empty lists. It has + ;; been written this way to save testing and car/cdring. + (if (less? ky kx) + (if (null? b) + (cons y (cons x a)) + (cons y (loop x kx a (car b) (key (car b)) (cdr b)))) + ;; x <= y + (if (null? a) + (cons x (cons y b)) + (cons x (loop (car a) (key (car a)) (cdr a) y ky b)))))))) (define (sort:merge! a b less? key) (define (loop r a kcara b kcarb) (cond ((less? kcarb kcara) - (set-cdr! r b) - (if (null? (cdr b)) - (set-cdr! b a) - (loop b a kcara (cdr b) (key (cadr b))))) - (else ; (car a) <= (car b) - (set-cdr! r a) - (if (null? (cdr a)) - (set-cdr! a b) - (loop a (cdr a) (key (cadr a)) b kcarb))))) + (set-cdr! r b) + (if (null? (cdr b)) + (set-cdr! b a) + (loop b a kcara (cdr b) (key (cadr b))))) + (else ; (car a) <= (car b) + (set-cdr! r a) + (if (null? (cdr a)) + (set-cdr! a b) + (loop a (cdr a) (key (cadr a)) b kcarb))))) (cond ((null? a) b) - ((null? b) a) - (else - (let ((kcara (key (car a))) - (kcarb (key (car b)))) - (cond - ((less? kcarb kcara) - (if (null? (cdr b)) - (set-cdr! b a) - (loop b a kcara (cdr b) (key (cadr b)))) - b) - (else ; (car a) <= (car b) - (if (null? (cdr a)) - (set-cdr! a b) - (loop a (cdr a) (key (cadr a)) b kcarb)) - a)))))) + ((null? b) a) + (else + (let ((kcara (key (car a))) + (kcarb (key (car b)))) + (cond + ((less? kcarb kcara) + (if (null? (cdr b)) + (set-cdr! b a) + (loop b a kcara (cdr b) (key (cadr b)))) + b) + (else ; (car a) <= (car b) + (if (null? (cdr a)) + (set-cdr! a b) + (loop a (cdr a) (key (cadr a)) b kcarb)) + a)))))) ;;; takes two sorted lists a and b and smashes their cdr fields to form a ;;; single sorted list including the elements of both. @@ -106,39 +106,39 @@ (define keyer (if key car identity)) (define (step n) (cond ((> n 2) (let* ((j (quotient n 2)) - (a (step j)) - (k (- n j)) - (b (step k))) - (sort:merge! a b less? keyer))) - ((= n 2) (let ((x (car seq)) - (y (cadr seq)) - (p seq)) - (set! seq (cddr seq)) - (cond ((less? (keyer y) (keyer x)) - (set-car! p y) - (set-car! (cdr p) x))) - (set-cdr! (cdr p) '()) - p)) - ((= n 1) (let ((p seq)) - (set! seq (cdr seq)) - (set-cdr! p '()) - p)) - (else '()))) + (a (step j)) + (k (- n j)) + (b (step k))) + (sort:merge! a b less? keyer))) + ((= n 2) (let ((x (car seq)) + (y (cadr seq)) + (p seq)) + (set! seq (cddr seq)) + (cond ((less? (keyer y) (keyer x)) + (set-car! p y) + (set-car! (cdr p) x))) + (set-cdr! (cdr p) '()) + p)) + ((= n 1) (let ((p seq)) + (set! seq (cdr seq)) + (set-cdr! p '()) + p)) + (else '()))) (define (key-wrap! lst) (cond ((null? lst)) - (else (set-car! lst (cons (key (car lst)) (car lst))) - (key-wrap! (cdr lst))))) + (else (set-car! lst (cons (key (car lst)) (car lst))) + (key-wrap! (cdr lst))))) (define (key-unwrap! lst) (cond ((null? lst)) - (else (set-car! lst (cdar lst)) - (key-unwrap! (cdr lst))))) + (else (set-car! lst (cdar lst)) + (key-unwrap! (cdr lst))))) (cond (key - (key-wrap! seq) - (set! seq (step (length seq))) - (key-unwrap! seq) - seq) - (else - (step (length seq))))) + (key-wrap! seq) + (set! seq (step (length seq))) + (key-unwrap! seq) + seq) + (else + (step (length seq))))) (define (rank-1-array->list array) (define dimensions (array-dimensions array)) @@ -156,22 +156,22 @@ (define (sort! seq less? . opt-key) (define key (if (null? opt-key) #f (car opt-key))) (cond ((array? seq) - (let ((dims (array-dimensions seq))) - (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key) - (cdr sorted)) - (i 0 (+ i 1))) - ((null? sorted) seq) - (array-set! seq (car sorted) i)))) - (else ; otherwise, assume it is a list - (let ((ret (sort:sort-list! seq less? key))) - (if (not (eq? ret seq)) - (do ((crt ret (cdr crt))) - ((eq? (cdr crt) seq) - (set-cdr! crt ret) - (let ((scar (car seq)) (scdr (cdr seq))) - (set-car! seq (car ret)) (set-cdr! seq (cdr ret)) - (set-car! ret scar) (set-cdr! ret scdr))))) - seq)))) + (let ((dims (array-dimensions seq))) + (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key) + (cdr sorted)) + (i 0 (+ i 1))) + ((null? sorted) seq) + (array-set! seq (car sorted) i)))) + (else ; otherwise, assume it is a list + (let ((ret (sort:sort-list! seq less? key))) + (if (not (eq? ret seq)) + (do ((crt ret (cdr crt))) + ((eq? (cdr crt) seq) + (set-cdr! crt ret) + (let ((scar (car seq)) (scdr (cdr seq))) + (set-car! seq (car ret)) (set-cdr! seq (cdr ret)) + (set-car! ret scar) (set-cdr! ret scdr))))) + seq)))) ;;; (sort sequence less?) ;;; sorts a array, string, or list non-destructively. It does this @@ -183,11 +183,11 @@ (define (sort seq less? . opt-key) (define key (if (null? opt-key) #f (car opt-key))) (cond ((array? seq) - (let ((dims (array-dimensions seq))) - (define newra (apply make-array seq dims)) - (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key) - (cdr sorted)) - (i 0 (+ i 1))) - ((null? sorted) newra) - (array-set! newra (car sorted) i)))) - (else (sort:sort-list! (append seq '()) less? key)))) + (let ((dims (array-dimensions seq))) + (define newra (apply make-array seq dims)) + (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key) + (cdr sorted)) + (i 0 (+ i 1))) + ((null? sorted) newra) + (array-set! newra (car sorted) i)))) + (else (sort:sort-list! (append seq '()) less? key)))) diff --git a/scheme-tests/ast/asttools.scm b/scheme-tests/ast/asttools.scm index 4b8e622..fea157b 100644 --- a/scheme-tests/ast/asttools.scm +++ b/scheme-tests/ast/asttools.scm @@ -11,8 +11,8 @@ (define (index-of item lst start) (cond ((null? lst) #f) - ((eq item (car lst)) start) - (#t (index-of item (cdr lst) (+ start 1))))) + ((eq item (car lst)) start) + (#t (index-of item (cdr lst) (+ start 1))))) (define (each f l) (if (null? l) l @@ -41,31 +41,33 @@ (f t zero) (f t (foldl t (lambda (e state) (foldtree-post f e state)) zero)))) -; general tree transformer -; folds in preorder (foldtree-pre), maps in postorder (maptree-post) -; therefore state changes occur immediately, just by looking at the current node, -; while transformation follows evaluation order. this seems to be the most natural -; approach. -; (mapper tree state) - should return transformed tree given current state -; (folder tree state) - should return new state +;; general tree transformer +;; +;; Folds in preorder (foldtree-pre), maps in postorder (maptree-post). +;; Therefore state changes occur immediately, just by looking at the current +;; node, while transformation follows evaluation order. This seems to be the +;; most natural approach. +;; +;; (mapper tree state) - should return transformed tree given current state +;; (folder tree state) - should return new state (define (map&fold t zero mapper folder) (let ((head (and (pair? t) (car t)))) (cond ((eq? head 'quote) - t) - ((or (eq? head 'the) (eq? head 'meta)) - (list head - (cadr t) - (map&fold (caddr t) zero mapper folder))) - (else - (let ((new-s (folder t zero))) - (mapper - (if (pair? t) - ; head symbol is a tag; never transform it - (cons (car t) - (map (lambda (e) (map&fold e new-s mapper folder)) - (cdr t))) - t) - new-s)))))) + t) + ((or (eq? head 'the) (eq? head 'meta)) + (list head + (cadr t) + (map&fold (caddr t) zero mapper folder))) + (else + (let ((new-s (folder t zero))) + (mapper + (if (pair? t) + ; head symbol is a tag; never transform it + (cons (car t) + (map (lambda (e) (map&fold e new-s mapper folder)) + (cdr t))) + t) + new-s)))))) ; convert to proper list, i.e. remove "dots", and append (define (append.2 l tail) @@ -77,11 +79,11 @@ ; env is a list of lexical variables in effect at that point. (define (lexical-walk f t) (map&fold t () f - (lambda (tree state) - (if (and (eq? (car t) 'lambda) - (pair? (cdr t))) - (append.2 (cadr t) state) - state)))) + (lambda (tree state) + (if (and (eq? (car t) 'lambda) + (pair? (cdr t))) + (append.2 (cadr t) state) + state)))) ; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e) (define (flatten-left-op op e) @@ -110,14 +112,14 @@ ((pair? e) (if (eq (car e) 'quote) e - (let* ((newvs (and (eq (car e) 'lambda) (cadr e))) - (newenv (if newvs (cons newvs env) env))) - (if newvs - (cons 'lambda - (cons (cadr e) - (map (lambda (se) (lvc- se newenv)) - (cddr e)))) - (map (lambda (se) (lvc- se env)) e))))) + (let* ((newvs (and (eq (car e) 'lambda) (cadr e))) + (newenv (if newvs (cons newvs env) env))) + (if newvs + (cons 'lambda + (cons (cadr e) + (map (lambda (se) (lvc- se newenv)) + (cddr e)))) + (map (lambda (se) (lvc- se env)) e))))) (#t e))) (define (lexical-var-conversion e) (lvc- e ())) @@ -125,32 +127,32 @@ ; convert let to lambda (define (let-expand e) (maptree-post (lambda (n) - (if (and (pair? n) (eq (car n) 'let)) - `((lambda ,(map car (cadr n)) ,@(cddr n)) - ,@(map cadr (cadr n))) + (if (and (pair? n) (eq (car n) 'let)) + `((lambda ,(map car (cadr n)) ,@(cddr n)) + ,@(map cadr (cadr n))) n)) - e)) + e)) ; alpha renaming ; transl is an assoc list ((old-sym-name . new-sym-name) ...) (define (alpha-rename e transl) (map&fold e - () - ; mapper: replace symbol if unbound - (lambda (t env) - (if (symbol? t) - (let ((found (assq t transl))) - (if (and found - (not (memq t env))) - (cdr found) - t)) - t)) - ; folder: add locals to environment if entering a new scope - (lambda (t env) - (if (and (pair? t) (or (eq? (car t) 'let) - (eq? (car t) 'lambda))) - (append (cadr t) env) - env)))) + () + ; mapper: replace symbol if unbound + (lambda (t env) + (if (symbol? t) + (let ((found (assq t transl))) + (if (and found + (not (memq t env))) + (cdr found) + t)) + t)) + ; folder: add locals to environment if entering a new scope + (lambda (t env) + (if (and (pair? t) (or (eq? (car t) 'let) + (eq? (car t) 'lambda))) + (append (cadr t) env) + env)))) ; flatten op with any associativity (define-macro (flatten-all-op op e) diff --git a/scheme-tests/ast/match-lsp.scm b/scheme-tests/ast/match-lsp.scm index f251ea3..7abb245 100644 --- a/scheme-tests/ast/match-lsp.scm +++ b/scheme-tests/ast/match-lsp.scm @@ -6,8 +6,8 @@ (if (null? lst) () (cons (car lst) - (filter (lambda (x) (not (eq x (car lst)))) - (unique (cdr lst)))))) + (filter (lambda (x) (not (eq x (car lst)))) + (unique (cdr lst)))))) ; list of special pattern symbols that cannot be variable names (define metasymbols '(_ ...)) @@ -40,44 +40,44 @@ ; (define (match- p expr state) (cond ((symbol? p) - (cond ((eq p '_) state) - (#t - (let ((capt (assq p state))) - (if capt - (and (equal? expr (cdr capt)) state) - (cons (cons p expr) state)))))) - - ((procedure? p) - (and (p expr) state)) - - ((pair? p) - (cond ((eq (car p) '-/) (and (equal? (cadr p) expr) state)) - ((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state)) - ((eq (car p) '--) - (and (match- (caddr p) expr state) - (cons (cons (cadr p) expr) state))) - ((eq (car p) '-$) ; greedy alternation for toplevel pattern - (match-alt (cdr p) () (list expr) state #f 1)) - (#t - (and (pair? expr) - (equal? (car p) (car expr)) - (match-seq (cdr p) (cdr expr) state (length (cdr expr))))))) - - (#t - (and (equal? p expr) state)))) + (cond ((eq p '_) state) + (#t + (let ((capt (assq p state))) + (if capt + (and (equal? expr (cdr capt)) state) + (cons (cons p expr) state)))))) + + ((procedure? p) + (and (p expr) state)) + + ((pair? p) + (cond ((eq (car p) '-/) (and (equal? (cadr p) expr) state)) + ((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state)) + ((eq (car p) '--) + (and (match- (caddr p) expr state) + (cons (cons (cadr p) expr) state))) + ((eq (car p) '-$) ; greedy alternation for toplevel pattern + (match-alt (cdr p) () (list expr) state #f 1)) + (#t + (and (pair? expr) + (equal? (car p) (car expr)) + (match-seq (cdr p) (cdr expr) state (length (cdr expr))))))) + + (#t + (and (equal? p expr) state)))) ; match an alternation (define (match-alt alt prest expr state var L) (if (null? alt) #f ; no alternatives left (let ((subma (match- (car alt) (car expr) state))) - (or (and subma - (match-seq prest (cdr expr) - (if var - (cons (cons var (car expr)) - subma) - subma) - (- L 1))) - (match-alt (cdr alt) prest expr state var L))))) + (or (and subma + (match-seq prest (cdr expr) + (if var + (cons (cons var (car expr)) + subma) + subma) + (- L 1))) + (match-alt (cdr alt) prest expr state var L))))) ; match generalized kleene star (try consuming min to max) (define (match-star- p prest expr state var min max L sofar) @@ -86,7 +86,7 @@ ; case 1: only allowed to match 0 subexpressions ((= max 0) (match-seq prest expr (if var (cons (cons var (reverse sofar)) state) - state) + state) L)) ; case 2: must match at least 1 ((> min 0) @@ -97,37 +97,37 @@ (#t (or (match-star- p prest expr state var 0 0 L sofar) (match-star- p prest expr state var 1 max L sofar))))) -(define (match-star p prest expr state var min max L) +(define (match-star p prest expr state var min max L) (match-star- p prest expr state var min max L ())) ; match sequences of expressions (define (match-seq p expr state L) (cond ((not state) #f) - ((null? p) (if (null? expr) state #f)) - (#t - (let ((subp (car p)) - (var #f)) - (if (and (pair? subp) - (eq (car subp) '--)) - (begin (set! var (cadr subp)) + ((null? p) (if (null? expr) state #f)) + (#t + (let ((subp (car p)) + (var #f)) + (if (and (pair? subp) + (eq (car subp) '--)) + (begin (set! var (cadr subp)) (set! subp (caddr subp))) - #f) - (let ((head (if (pair? subp) (car subp) ()))) - (cond ((eq subp '...) - (match-star '_ (cdr p) expr state var 0 L L)) - ((eq head '-*) - (match-star (cadr subp) (cdr p) expr state var 0 L L)) - ((eq head '-+) - (match-star (cadr subp) (cdr p) expr state var 1 L L)) - ((eq head '-?) - (match-star (cadr subp) (cdr p) expr state var 0 1 L)) - ((eq head '-$) - (match-alt (cdr subp) (cdr p) expr state var L)) - (#t - (and (pair? expr) - (match-seq (cdr p) (cdr expr) - (match- (car p) (car expr) state) - (- L 1)))))))))) + #f) + (let ((head (if (pair? subp) (car subp) ()))) + (cond ((eq subp '...) + (match-star '_ (cdr p) expr state var 0 L L)) + ((eq head '-*) + (match-star (cadr subp) (cdr p) expr state var 0 L L)) + ((eq head '-+) + (match-star (cadr subp) (cdr p) expr state var 1 L L)) + ((eq head '-?) + (match-star (cadr subp) (cdr p) expr state var 0 1 L)) + ((eq head '-$) + (match-alt (cdr subp) (cdr p) expr state var L)) + (#t + (and (pair? expr) + (match-seq (cdr p) (cdr expr) + (match- (car p) (car expr) state) + (- L 1)))))))))) (define (match p expr) (match- p expr (list (cons '__ expr)))) @@ -136,12 +136,12 @@ (cond ((and (symbol? p) (not (member p metasymbols))) (list p)) - + ((pair? p) (if (eq (car p) '-/) () - (unique (apply append (map patargs- (cdr p)))))) - + (unique (apply append (map patargs- (cdr p)))))) + (#t ()))) (define (patargs p) (cons '__ (patargs- p))) @@ -151,14 +151,14 @@ (define (apply-patterns plist expr) (if (null? plist) expr (if (procedure? plist) - (let ((enew (plist expr))) - (if (not enew) - expr - enew)) - (let ((enew ((car plist) expr))) - (if (not enew) - (apply-patterns (cdr plist) expr) - enew))))) + (let ((enew (plist expr))) + (if (not enew) + expr + enew)) + (let ((enew ((car plist) expr))) + (if (not enew) + (apply-patterns (cdr plist) expr) + enew))))) ; top-down fixed-point macroexpansion. this is a typical algorithm, ; but it may leave some structure that matches a pattern unexpanded. @@ -173,9 +173,9 @@ (if (not (pair? expr)) expr (let ((enew (apply-patterns plist expr))) - (if (eq enew expr) + (if (eq enew expr) ; expr didn't change; move to subexpressions - (cons (car expr) - (map (lambda (subex) (pattern-expand plist subex)) (cdr expr))) - ; expr changed; iterate - (pattern-expand plist enew))))) + (cons (car expr) + (map (lambda (subex) (pattern-expand plist subex)) (cdr expr))) + ; expr changed; iterate + (pattern-expand plist enew))))) diff --git a/scheme-tests/ast/match.scm b/scheme-tests/ast/match.scm index ff7257c..762bf5f 100644 --- a/scheme-tests/ast/match.scm +++ b/scheme-tests/ast/match.scm @@ -32,44 +32,44 @@ ; (define (match- p expr state) (cond ((symbol? p) - (cond ((eq? p '_) state) - (else - (let ((capt (assq p state))) - (if capt - (and (equal? expr (cdr capt)) state) - (cons (cons p expr) state)))))) - - ((procedure? p) - (and (p expr) state)) - - ((pair? p) - (cond ((eq? (car p) '-/) (and (equal? (cadr p) expr) state)) - ((eq? (car p) '-^) (and (not (match- (cadr p) expr state)) state)) - ((eq? (car p) '--) - (and (match- (caddr p) expr state) - (cons (cons (cadr p) expr) state))) - ((eq? (car p) '-$) ; greedy alternation for toplevel pattern - (match-alt (cdr p) () (list expr) state #f 1)) - (else - (and (pair? expr) - (equal? (car p) (car expr)) - (match-seq (cdr p) (cdr expr) state (length (cdr expr))))))) - - (else - (and (equal? p expr) state)))) + (cond ((eq? p '_) state) + (else + (let ((capt (assq p state))) + (if capt + (and (equal? expr (cdr capt)) state) + (cons (cons p expr) state)))))) + + ((procedure? p) + (and (p expr) state)) + + ((pair? p) + (cond ((eq? (car p) '-/) (and (equal? (cadr p) expr) state)) + ((eq? (car p) '-^) (and (not (match- (cadr p) expr state)) state)) + ((eq? (car p) '--) + (and (match- (caddr p) expr state) + (cons (cons (cadr p) expr) state))) + ((eq? (car p) '-$) ; greedy alternation for toplevel pattern + (match-alt (cdr p) () (list expr) state #f 1)) + (else + (and (pair? expr) + (equal? (car p) (car expr)) + (match-seq (cdr p) (cdr expr) state (length (cdr expr))))))) + + (else + (and (equal? p expr) state)))) ; match an alternation (define (match-alt alt prest expr state var L) (if (null? alt) #f ; no alternatives left (let ((subma (match- (car alt) (car expr) state))) - (or (and subma - (match-seq prest (cdr expr) - (if var - (cons (cons var (car expr)) - subma) - subma) - (- L 1))) - (match-alt (cdr alt) prest expr state var L))))) + (or (and subma + (match-seq prest (cdr expr) + (if var + (cons (cons var (car expr)) + subma) + subma) + (- L 1))) + (match-alt (cdr alt) prest expr state var L))))) ; match generalized kleene star (try consuming min to max) (define (match-star p prest expr state var min max L) @@ -78,49 +78,49 @@ ((> min max) #f) ; case 1: only allowed to match 0 subexpressions ((= max 0) (match-seq prest expr - (if var (cons (cons var (reverse sofar)) state) - state) - L)) + (if var (cons (cons var (reverse sofar)) state) + state) + L)) ; case 2: must match at least 1 - ((> min 0) - (and (match- p (car expr) state) - (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1) - (cons (car expr) sofar)))) + ((> min 0) + (and (match- p (car expr) state) + (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1) + (cons (car expr) sofar)))) ; otherwise, must match either 0 or between 1 and max subexpressions - (else - (or (match-star- p prest expr state var 0 0 L sofar) - (match-star- p prest expr state var 1 max L sofar))))) - + (else + (or (match-star- p prest expr state var 0 0 L sofar) + (match-star- p prest expr state var 1 max L sofar))))) + (match-star- p prest expr state var min max L ())) ; match sequences of expressions (define (match-seq p expr state L) (cond ((not state) #f) - ((null? p) (if (null? expr) state #f)) - (else - (let ((subp (car p)) - (var #f)) - (if (and (pair? subp) - (eq? (car subp) '--)) - (begin (set! var (cadr subp)) - (set! subp (caddr subp))) - #f) - (let ((head (if (pair? subp) (car subp) ()))) - (cond ((eq? subp '...) - (match-star '_ (cdr p) expr state var 0 L L)) - ((eq? head '-*) - (match-star (cadr subp) (cdr p) expr state var 0 L L)) - ((eq? head '-+) - (match-star (cadr subp) (cdr p) expr state var 1 L L)) - ((eq? head '-?) - (match-star (cadr subp) (cdr p) expr state var 0 1 L)) - ((eq? head '-$) - (match-alt (cdr subp) (cdr p) expr state var L)) - (else - (and (pair? expr) - (match-seq (cdr p) (cdr expr) - (match- (car p) (car expr) state) - (- L 1)))))))))) + ((null? p) (if (null? expr) state #f)) + (else + (let ((subp (car p)) + (var #f)) + (if (and (pair? subp) + (eq? (car subp) '--)) + (begin (set! var (cadr subp)) + (set! subp (caddr subp))) + #f) + (let ((head (if (pair? subp) (car subp) ()))) + (cond ((eq? subp '...) + (match-star '_ (cdr p) expr state var 0 L L)) + ((eq? head '-*) + (match-star (cadr subp) (cdr p) expr state var 0 L L)) + ((eq? head '-+) + (match-star (cadr subp) (cdr p) expr state var 1 L L)) + ((eq? head '-?) + (match-star (cadr subp) (cdr p) expr state var 0 1 L)) + ((eq? head '-$) + (match-alt (cdr subp) (cdr p) expr state var L)) + (else + (and (pair? expr) + (match-seq (cdr p) (cdr expr) + (match- (car p) (car expr) state) + (- L 1)))))))))) (define (match p expr) (match- p expr (list (cons '__ expr)))) @@ -128,15 +128,15 @@ (define (patargs p) (define (patargs- p) (cond ((and (symbol? p) - (not (member p metasymbols))) - (list p)) - - ((pair? p) - (if (eq? (car p) '-/) - () - (delete-duplicates (apply append (map patargs- (cdr p)))))) - - (else ()))) + (not (member p metasymbols))) + (list p)) + + ((pair? p) + (if (eq? (car p) '-/) + () + (delete-duplicates (apply append (map patargs- (cdr p)))))) + + (else ()))) (cons '__ (patargs- p))) ; try to transform expr using a pattern-lambda from plist @@ -144,14 +144,14 @@ (define (apply-patterns plist expr) (if (null? plist) expr (if (procedure? plist) - (let ((enew (plist expr))) - (if (not enew) - expr - enew)) - (let ((enew ((car plist) expr))) - (if (not enew) - (apply-patterns (cdr plist) expr) - enew))))) + (let ((enew (plist expr))) + (if (not enew) + expr + enew)) + (let ((enew ((car plist) expr))) + (if (not enew) + (apply-patterns (cdr plist) expr) + enew))))) ; top-down fixed-point macroexpansion. this is a typical algorithm, ; but it may leave some structure that matches a pattern unexpanded. @@ -166,9 +166,9 @@ (if (not (pair? expr)) expr (let ((enew (apply-patterns plist expr))) - (if (eq? enew expr) - ; expr didn't change; move to subexpressions - (cons (car expr) - (map (lambda (subex) (pattern-expand plist subex)) (cdr expr))) - ; expr changed; iterate - (pattern-expand plist enew))))) + (if (eq? enew expr) + ; expr didn't change; move to subexpressions + (cons (car expr) + (map (lambda (subex) (pattern-expand plist subex)) (cdr expr))) + ; expr changed; iterate + (pattern-expand plist enew))))) diff --git a/scheme-tests/ast/rpasses-out.scm b/scheme-tests/ast/rpasses-out.scm index 4028395..ab8b9bf 100644 --- a/scheme-tests/ast/rpasses-out.scm +++ b/scheme-tests/ast/rpasses-out.scm @@ -1,1701 +1,1701 @@ '(r-expressions (<- Sys.time (lambda () - (let () (r-block (r-call structure (r-call - .Internal (r-call + (let () (r-block (r-call structure (r-call + .Internal (r-call Sys.time)) - (*named* class (r-call + (*named* class (r-call c "POSIXt" "POSIXct"))))))) - (<- Sys.timezone (lambda () - (let () - (r-block (r-call as.vector (r-call - Sys.getenv - "TZ")))))) - (<- as.POSIXlt (lambda (x tz) - (let ((x ()) - (tzone ()) - (fromchar ()) - (tz ())) - (r-block (when (missing tz) - (<- tz "")) - (<- fromchar (lambda (x) - (let ((res ()) - (f ()) - (j ()) - (xx ())) - (r-block (<- + (<- Sys.timezone (lambda () + (let () + (r-block (r-call as.vector (r-call + Sys.getenv + "TZ")))))) + (<- as.POSIXlt (lambda (x tz) + (let ((x ()) + (tzone ()) + (fromchar ()) + (tz ())) + (r-block (when (missing tz) + (<- tz "")) + (<- fromchar (lambda (x) + (let ((res ()) + (f ()) + (j ()) + (xx ())) + (r-block (<- xx (r-call r-index x 1)) (if (r-call is.na xx) (r-block (<- j 1) - (while (&& (r-call is.na xx) - (r-call <= (<- j (r-call + j 1)) - (r-call length x))) - (<- xx (r-call r-index x j))) - (if (r-call is.na xx) - (<- f "%Y-%m-%d")))) + (while (&& (r-call is.na xx) + (r-call <= (<- j (r-call + j 1)) + (r-call length x))) + (<- xx (r-call r-index x j))) + (if (r-call is.na xx) + (<- f "%Y-%m-%d")))) (if (|\|\|| (r-call is.na xx) (r-call ! (r-call is.na (r-call strptime xx - (<- f "%Y-%m-%d %H:%M:%OS")))) - (r-call ! (r-call is.na (r-call strptime xx - (<- f "%Y/%m/%d %H:%M:%OS")))) - (r-call ! (r-call is.na (r-call strptime xx - (<- f "%Y-%m-%d %H:%M")))) - (r-call ! (r-call is.na (r-call strptime xx - (<- f "%Y/%m/%d %H:%M")))) - (r-call ! (r-call is.na (r-call strptime xx - (<- f "%Y-%m-%d")))) - (r-call ! (r-call is.na (r-call strptime xx - (<- f "%Y/%m/%d"))))) + (<- f "%Y-%m-%d %H:%M:%OS")))) + (r-call ! (r-call is.na (r-call strptime xx + (<- f "%Y/%m/%d %H:%M:%OS")))) + (r-call ! (r-call is.na (r-call strptime xx + (<- f "%Y-%m-%d %H:%M")))) + (r-call ! (r-call is.na (r-call strptime xx + (<- f "%Y/%m/%d %H:%M")))) + (r-call ! (r-call is.na (r-call strptime xx + (<- f "%Y-%m-%d")))) + (r-call ! (r-call is.na (r-call strptime xx + (<- f "%Y/%m/%d"))))) (r-block (<- res (r-call strptime x f)) - (if (r-call nchar tz) (r-block (<- res (r-call attr<- res "tzone" - tz)) - tz)) - (return res))) + (if (r-call nchar tz) (r-block (<- res (r-call attr<- res "tzone" + tz)) + tz)) + (return res))) (r-call stop "character string is not in a standard unambiguous format"))))) - (if (r-call inherits x "POSIXlt") - (return x)) - (if (r-call inherits x "Date") - (return (r-call .Internal (r-call + (if (r-call inherits x "POSIXlt") + (return x)) + (if (r-call inherits x "Date") + (return (r-call .Internal (r-call Date2POSIXlt x)))) - (<- tzone (r-call attr x "tzone")) - (if (|\|\|| (r-call inherits x "date") - (r-call inherits x "dates")) - (<- x (r-call as.POSIXct x))) - (if (r-call is.character x) - (return (r-call fromchar (r-call + (<- tzone (r-call attr x "tzone")) + (if (|\|\|| (r-call inherits x "date") + (r-call inherits x "dates")) + (<- x (r-call as.POSIXct x))) + (if (r-call is.character x) + (return (r-call fromchar (r-call unclass x)))) - (if (r-call is.factor x) - (return (r-call fromchar (r-call + (if (r-call is.factor x) + (return (r-call fromchar (r-call as.character x)))) - (if (&& (r-call is.logical x) - (r-call all (r-call is.na + (if (&& (r-call is.logical x) + (r-call all (r-call is.na x))) - (<- x (r-call - as.POSIXct.default x))) - (if (r-call ! (r-call inherits x - "POSIXct")) - (r-call stop (r-call gettextf + (<- x (r-call + as.POSIXct.default x))) + (if (r-call ! (r-call inherits x + "POSIXct")) + (r-call stop (r-call gettextf "do not know how to convert '%s' to class \"POSIXlt\"" (r-call deparse (substitute x))))) - (if (&& (missing tz) - (r-call ! (r-call is.null + (if (&& (missing tz) + (r-call ! (r-call is.null tzone))) - (<- tz (r-call r-index tzone - 1))) - (r-call .Internal (r-call - as.POSIXlt x - tz)))))) - (<- as.POSIXct (lambda (x tz) - (let ((tz ())) - (r-block (when (missing tz) - (<- tz "")) - (r-call UseMethod "as.POSIXct"))))) - (<- as.POSIXct.Date (lambda (x ...) - (let () - (r-block (r-call structure (r-call * + (<- tz (r-call r-index tzone + 1))) + (r-call .Internal (r-call + as.POSIXlt x + tz)))))) + (<- as.POSIXct (lambda (x tz) + (let ((tz ())) + (r-block (when (missing tz) + (<- tz "")) + (r-call UseMethod "as.POSIXct"))))) + (<- as.POSIXct.Date (lambda (x ...) + (let () + (r-block (r-call structure (r-call * (r-call unclass x) 86400) - (*named* class (r-call + (*named* class (r-call c "POSIXt" "POSIXct"))))))) - (<- as.POSIXct.date (lambda (x ...) - (let ((x ())) - (r-block (if (r-call inherits x "date") - (r-block (<- x (r-call + (<- as.POSIXct.date (lambda (x ...) + (let ((x ())) + (r-block (if (r-call inherits x "date") + (r-block (<- x (r-call * (r-call - x 3653) 86400)) - (return (r-call + (return (r-call structure x (*named* class (r-call c "POSIXt" "POSIXct"))))) - (r-call stop (r-call + (r-call stop (r-call gettextf "'%s' is not a \"date\" object" (r-call deparse (substitute x))))))))) - (<- as.POSIXct.dates (lambda (x ...) - (let ((x ()) - (z ())) - (r-block (if (r-call inherits x "dates") - (r-block (<- z (r-call + (<- as.POSIXct.dates (lambda (x ...) + (let ((x ()) + (z ())) + (r-block (if (r-call inherits x "dates") + (r-block (<- z (r-call attr x "origin")) - (<- x (r-call + (<- x (r-call * (r-call as.numeric x) 86400)) - (if (&& (r-call + (if (&& (r-call == (r-call length z) 3) (r-call is.numeric z)) (<- x (r-call + x - (r-call as.numeric (r-call ISOdate (r-call r-index z 3) - (r-call r-index z 1) - (r-call r-index z 2) 0))))) - (return (r-call + (r-call as.numeric (r-call ISOdate (r-call r-index z 3) + (r-call r-index z 1) + (r-call r-index z 2) 0))))) + (return (r-call structure x (*named* class (r-call c "POSIXt" "POSIXct"))))) - (r-call stop (r-call + (r-call stop (r-call gettextf "'%s' is not a \"dates\" object" (r-call deparse (substitute x))))))))) - (<- as.POSIXct.POSIXlt (lambda (x tz) - (let ((tzone ()) - (tz ())) - (r-block (when (missing tz) - (<- tz "")) - (<- tzone (r-call attr x + (<- as.POSIXct.POSIXlt (lambda (x tz) + (let ((tzone ()) + (tz ())) + (r-block (when (missing tz) + (<- tz "")) + (<- tzone (r-call attr x "tzone")) - (if (&& (missing tz) - (r-call ! (r-call + (if (&& (missing tz) + (r-call ! (r-call is.null tzone))) - (<- tz (r-call - r-index tzone - 1))) - (r-call structure (r-call + (<- tz (r-call + r-index tzone + 1))) + (r-call structure (r-call .Internal (r-call as.POSIXct x tz)) - (*named* class (r-call + (*named* class (r-call c "POSIXt" "POSIXct")) - (*named* tzone tz)))))) - (<- as.POSIXct.default (lambda (x tz) - (let ((tz ())) - (r-block (when (missing tz) - (<- tz "")) - (if (r-call inherits x "POSIXct") - (return x)) - (if (|\|\|| (r-call - is.character - x) - (r-call - is.factor x)) - (return (r-call - as.POSIXct - (r-call - as.POSIXlt - x) - tz))) - (if (&& (r-call - is.logical x) - (r-call all (r-call + (*named* tzone tz)))))) + (<- as.POSIXct.default (lambda (x tz) + (let ((tz ())) + (r-block (when (missing tz) + (<- tz "")) + (if (r-call inherits x "POSIXct") + (return x)) + (if (|\|\|| (r-call + is.character + x) + (r-call + is.factor x)) + (return (r-call + as.POSIXct + (r-call + as.POSIXlt + x) + tz))) + (if (&& (r-call + is.logical x) + (r-call all (r-call is.na x))) - (return (r-call - structure (r-call + (return (r-call + structure (r-call as.numeric x) - (*named* - class (r-call + (*named* + class (r-call c "POSIXt" "POSIXct"))))) - (r-call stop (r-call - gettextf "do not know how to convert '%s' to class \"POSIXlt\"" - (r-call + (r-call stop (r-call + gettextf "do not know how to convert '%s' to class \"POSIXlt\"" + (r-call deparse (substitute x)))))))) - (<- as.numeric.POSIXlt (lambda (x) - (let () - (r-block (r-call as.POSIXct x))))) - (<- format.POSIXlt (lambda (x format usetz ...) - (let ((np ()) - (secs ()) - (times ()) - (usetz ()) - (format ())) - (r-block (when (missing format) - (<- format "")) - (when (missing usetz) - (<- usetz *r-false*)) - (if (r-call ! (r-call - inherits x "POSIXlt")) - (r-call stop "wrong class")) - (if (r-call == format "") - (r-block (<- times (r-call + (<- as.numeric.POSIXlt (lambda (x) + (let () + (r-block (r-call as.POSIXct x))))) + (<- format.POSIXlt (lambda (x format usetz ...) + (let ((np ()) + (secs ()) + (times ()) + (usetz ()) + (format ())) + (r-block (when (missing format) + (<- format "")) + (when (missing usetz) + (<- usetz *r-false*)) + (if (r-call ! (r-call + inherits x "POSIXlt")) + (r-call stop "wrong class")) + (if (r-call == format "") + (r-block (<- times (r-call unlist (r-call r-index (r-call unclass x) - (r-call : 1 3)))) - (<- secs (r-call + (r-call : 1 3)))) + (<- secs (r-call r-aref x (index-in-strlist sec (r-call attr x #0="names")))) - (<- secs (r-call + (<- secs (r-call r-index secs (r-call ! (r-call is.na secs)))) - (<- np (r-call + (<- np (r-call getOption "digits.secs")) - (if (r-call - is.null np) - (<- np 0) - (<- np (r-call + (if (r-call + is.null np) + (<- np 0) + (<- np (r-call min 6 np))) - (if (r-call >= + (if (r-call >= np 1) - (r-block (for + (r-block (for i (r-call - (r-call : 1 np) 1) (if (r-call all (r-call < (r-call abs (r-call - secs - (r-call round secs i))) - 9.9999999999999995e-07)) + (r-call round secs i))) + 9.9999999999999995e-07)) (r-block (<- np i) (break)))))) - (<- format (if + (<- format (if (r-call all (r-call == (r-call r-index times - (r-call ! (r-call is.na times))) - 0)) + (r-call ! (r-call is.na times))) + 0)) "%Y-%m-%d" (if (r-call == np 0) "%Y-%m-%d %H:%M:%S" - (r-call paste "%Y-%m-%d %H:%M:%OS" np - (*named* sep ""))))))) - (r-call .Internal (r-call + (r-call paste "%Y-%m-%d %H:%M:%OS" np + (*named* sep ""))))))) + (r-call .Internal (r-call format.POSIXlt x format usetz)))))) - (<- strftime format.POSIXlt) - (<- strptime (lambda (x format tz) - (let ((tz ())) - (r-block (when (missing tz) - (<- tz "")) - (r-call .Internal (r-call strptime + (<- strftime format.POSIXlt) + (<- strptime (lambda (x format tz) + (let ((tz ())) + (r-block (when (missing tz) + (<- tz "")) + (r-call .Internal (r-call strptime (r-call as.character x) format tz)))))) - (<- format.POSIXct (lambda (x format tz usetz ...) - (let ((tzone ()) - (usetz ()) - (tz ()) - (format ())) - (r-block (when (missing format) - (<- format "")) - (when (missing tz) - (<- tz "")) - (when (missing usetz) - (<- usetz *r-false*)) - (if (r-call ! (r-call - inherits x "POSIXct")) - (r-call stop "wrong class")) - (if (&& (missing tz) - (r-call ! (r-call + (<- format.POSIXct (lambda (x format tz usetz ...) + (let ((tzone ()) + (usetz ()) + (tz ()) + (format ())) + (r-block (when (missing format) + (<- format "")) + (when (missing tz) + (<- tz "")) + (when (missing usetz) + (<- usetz *r-false*)) + (if (r-call ! (r-call + inherits x "POSIXct")) + (r-call stop "wrong class")) + (if (&& (missing tz) + (r-call ! (r-call is.null (<- tzone (r-call attr x "tzone"))))) - (<- tz tzone)) - (r-call structure (r-call + (<- tz tzone)) + (r-call structure (r-call format.POSIXlt (r-call as.POSIXlt x tz) format usetz r-dotdotdot) - (*named* names (r-call + (*named* names (r-call names x))))))) - (<- print.POSIXct (lambda (x ...) - (let () - (r-block (r-call print (r-call format + (<- print.POSIXct (lambda (x ...) + (let () + (r-block (r-call print (r-call format x (*named* usetz *r-true*) r-dotdotdot) - r-dotdotdot) - (r-call invisible x))))) - (<- print.POSIXlt (lambda (x ...) - (let () - (r-block (r-call print (r-call format + r-dotdotdot) + (r-call invisible x))))) + (<- print.POSIXlt (lambda (x ...) + (let () + (r-block (r-call print (r-call format x (*named* usetz *r-true*)) - r-dotdotdot) - (r-call invisible x))))) - (<- summary.POSIXct (lambda (object digits ...) - (let ((x ()) - (digits ())) - (r-block (when (missing digits) - (<- digits 15)) - (<- x (r-call r-index (r-call + r-dotdotdot) + (r-call invisible x))))) + (<- summary.POSIXct (lambda (object digits ...) + (let ((x ()) + (digits ())) + (r-block (when (missing digits) + (<- digits 15)) + (<- x (r-call r-index (r-call summary.default (r-call unclass object) (*named* digits digits) r-dotdotdot) - (r-call : 1 6))) - (r-block (ref= %r:1 (r-call + (r-call : 1 6))) + (r-block (ref= %r:1 (r-call oldClass object)) - (<- x (r-call - class<- x - %r:1)) - %r:1) - (r-block (ref= %r:2 (r-call + (<- x (r-call + class<- x + %r:1)) + %r:1) + (r-block (ref= %r:2 (r-call attr object "tzone")) - (<- x (r-call - attr<- x "tzone" - %r:2)) - %r:2) - x)))) - (<- summary.POSIXlt (lambda (object digits ...) - (let ((digits ())) - (r-block (when (missing digits) - (<- digits 15)) - (r-call summary (r-call - as.POSIXct - object) - (*named* digits - digits) - r-dotdotdot))))) - (<- "+.POSIXt" (lambda (e1 e2) - (let ((e2 ()) - (e1 ()) - (coerceTimeUnit ())) - (r-block (<- coerceTimeUnit (lambda (x) - (let () + (<- x (r-call + attr<- x "tzone" + %r:2)) + %r:2) + x)))) + (<- summary.POSIXlt (lambda (object digits ...) + (let ((digits ())) + (r-block (when (missing digits) + (<- digits 15)) + (r-call summary (r-call + as.POSIXct + object) + (*named* digits + digits) + r-dotdotdot))))) + (<- "+.POSIXt" (lambda (e1 e2) + (let ((e2 ()) + (e1 ()) + (coerceTimeUnit ())) + (r-block (<- coerceTimeUnit (lambda (x) + (let () (r-block (switch (r-call attr x "units") - (*named* secs x) (*named* mins (r-call * 60 x)) - (*named* hours (r-call * (r-call * 60 60) x)) - (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) - (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) - 24) - 7) - x))))))) - (if (r-call == (r-call nargs) 1) - (return e1)) - (if (&& (r-call inherits e1 "POSIXt") - (r-call inherits e2 "POSIXt")) - (r-call stop "binary + is not defined for \"POSIXt\" objects")) - (if (r-call inherits e1 "POSIXlt") - (<- e1 (r-call as.POSIXct e1))) - (if (r-call inherits e2 "POSIXlt") - (<- e2 (r-call as.POSIXct e2))) - (if (r-call inherits e1 "difftime") - (<- e1 (r-call coerceTimeUnit - e1))) - (if (r-call inherits e2 "difftime") - (<- e2 (r-call coerceTimeUnit - e2))) - (r-call structure (r-call + (r-call + (*named* secs x) (*named* mins (r-call * 60 x)) + (*named* hours (r-call * (r-call * 60 60) x)) + (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) + (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) + 24) + 7) + x))))))) + (if (r-call == (r-call nargs) 1) + (return e1)) + (if (&& (r-call inherits e1 "POSIXt") + (r-call inherits e2 "POSIXt")) + (r-call stop "binary + is not defined for \"POSIXt\" objects")) + (if (r-call inherits e1 "POSIXlt") + (<- e1 (r-call as.POSIXct e1))) + (if (r-call inherits e2 "POSIXlt") + (<- e2 (r-call as.POSIXct e2))) + (if (r-call inherits e1 "difftime") + (<- e1 (r-call coerceTimeUnit + e1))) + (if (r-call inherits e2 "difftime") + (<- e2 (r-call coerceTimeUnit + e2))) + (r-call structure (r-call + (r-call unclass e1) (r-call unclass e2)) - (*named* class (r-call c + (*named* class (r-call c "POSIXt" "POSIXct")) - (*named* tzone (r-call + (*named* tzone (r-call check_tzones e1 e2))))))) - (<- "-.POSIXt" (lambda (e1 e2) - (let ((e2 ()) - (coerceTimeUnit ())) - (r-block (<- coerceTimeUnit (lambda (x) - (let () + (<- "-.POSIXt" (lambda (e1 e2) + (let ((e2 ()) + (coerceTimeUnit ())) + (r-block (<- coerceTimeUnit (lambda (x) + (let () (r-block (switch (r-call attr x "units") - (*named* secs x) (*named* mins (r-call * 60 x)) - (*named* hours (r-call * (r-call * 60 60) x)) - (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) - (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) - 24) - 7) - x))))))) - (if (r-call ! (r-call inherits e1 - "POSIXt")) - (r-call stop "Can only subtract from POSIXt objects")) - (if (r-call == (r-call nargs) 1) - (r-call stop "unary - is not defined for \"POSIXt\" objects")) - (if (r-call inherits e2 "POSIXt") - (return (r-call difftime e1 - e2))) - (if (r-call inherits e2 "difftime") - (<- e2 (r-call unclass (r-call + (*named* secs x) (*named* mins (r-call * 60 x)) + (*named* hours (r-call * (r-call * 60 60) x)) + (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) + (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) + 24) + 7) + x))))))) + (if (r-call ! (r-call inherits e1 + "POSIXt")) + (r-call stop "Can only subtract from POSIXt objects")) + (if (r-call == (r-call nargs) 1) + (r-call stop "unary - is not defined for \"POSIXt\" objects")) + (if (r-call inherits e2 "POSIXt") + (return (r-call difftime e1 + e2))) + (if (r-call inherits e2 "difftime") + (<- e2 (r-call unclass (r-call coerceTimeUnit e2)))) - (if (r-call ! (r-call is.null (r-call + (if (r-call ! (r-call is.null (r-call attr e2 "class"))) - (r-call stop "can only subtract numbers from POSIXt objects")) - (r-call structure (r-call - (r-call + (r-call stop "can only subtract numbers from POSIXt objects")) + (r-call structure (r-call - (r-call unclass (r-call as.POSIXct e1)) e2) - (*named* class (r-call c + (*named* class (r-call c "POSIXt" "POSIXct"))))))) - (<- Ops.POSIXt (lambda (e1 e2) - (let ((e2 ()) - (e1 ()) - (boolean ())) - (r-block (if (r-call == (r-call nargs) 1) - (r-call stop "unary" .Generic - " not defined for \"POSIXt\" objects")) - (<- boolean (switch .Generic (*named* + (<- Ops.POSIXt (lambda (e1 e2) + (let ((e2 ()) + (e1 ()) + (boolean ())) + (r-block (if (r-call == (r-call nargs) 1) + (r-call stop "unary" .Generic + " not defined for \"POSIXt\" objects")) + (<- boolean (switch .Generic (*named* < *r-missing*) - (*named* > + (*named* > *r-missing*) - (*named* == + (*named* == *r-missing*) - (*named* != + (*named* != *r-missing*) - (*named* <= + (*named* <= *r-missing*) - (*named* >= + (*named* >= *r-true*) - *r-false*)) - (if (r-call ! boolean) - (r-call stop .Generic - " not defined for \"POSIXt\" objects")) - (if (|\|\|| (r-call inherits e1 - "POSIXlt") - (r-call is.character - e1)) - (<- e1 (r-call as.POSIXct e1))) - (if (|\|\|| (r-call inherits e2 - "POSIXlt") - (r-call is.character - e1)) - (<- e2 (r-call as.POSIXct e2))) - (r-call check_tzones e1 e2) - (r-call NextMethod .Generic))))) - (<- Math.POSIXt (lambda (x ...) - (let () (r-block (r-call stop .Generic - " not defined for POSIXt objects"))))) - (<- check_tzones (lambda (...) - (let ((tzs ())) - (r-block (<- tzs (r-call unique (r-call + *r-false*)) + (if (r-call ! boolean) + (r-call stop .Generic + " not defined for \"POSIXt\" objects")) + (if (|\|\|| (r-call inherits e1 + "POSIXlt") + (r-call is.character + e1)) + (<- e1 (r-call as.POSIXct e1))) + (if (|\|\|| (r-call inherits e2 + "POSIXlt") + (r-call is.character + e1)) + (<- e2 (r-call as.POSIXct e2))) + (r-call check_tzones e1 e2) + (r-call NextMethod .Generic))))) + (<- Math.POSIXt (lambda (x ...) + (let () (r-block (r-call stop .Generic + " not defined for POSIXt objects"))))) + (<- check_tzones (lambda (...) + (let ((tzs ())) + (r-block (<- tzs (r-call unique (r-call sapply (r-call list r-dotdotdot) (lambda (x) - (let ((y ())) - (r-block (<- y (r-call attr x "tzone")) - (if (r-call is.null y) "" y))))))) - (<- tzs (r-call r-index tzs - (r-call != tzs + (let ((y ())) + (r-block (<- y (r-call attr x "tzone")) + (if (r-call is.null y) "" y))))))) + (<- tzs (r-call r-index tzs + (r-call != tzs ""))) - (if (r-call > (r-call length + (if (r-call > (r-call length tzs) - 1) - (r-call warning "'tzone' attributes are inconsistent")) - (if (r-call length tzs) - (r-call r-index tzs 1) - ()))))) - (<- Summary.POSIXct (lambda (... na.rm) - (let ((val ()) - (tz ()) - (args ()) - (ok ())) - (r-block (<- ok (switch .Generic (*named* + 1) + (r-call warning "'tzone' attributes are inconsistent")) + (if (r-call length tzs) + (r-call r-index tzs 1) + ()))))) + (<- Summary.POSIXct (lambda (... na.rm) + (let ((val ()) + (tz ()) + (args ()) + (ok ())) + (r-block (<- ok (switch .Generic (*named* max *r-missing*) - (*named* min + (*named* min *r-missing*) - (*named* - range - *r-true*) - *r-false*)) - (if (r-call ! ok) - (r-call stop .Generic - " not defined for \"POSIXct\" objects")) - (<- args (r-call list - r-dotdotdot)) - (<- tz (r-call do.call "check_tzones" - args)) - (<- val (r-call NextMethod - .Generic)) - (r-block (ref= %r:3 (r-call + (*named* + range + *r-true*) + *r-false*)) + (if (r-call ! ok) + (r-call stop .Generic + " not defined for \"POSIXct\" objects")) + (<- args (r-call list + r-dotdotdot)) + (<- tz (r-call do.call "check_tzones" + args)) + (<- val (r-call NextMethod + .Generic)) + (r-block (ref= %r:3 (r-call oldClass (r-call r-aref args 1))) - (<- val (r-call + (<- val (r-call class<- val %r:3)) - %r:3) - (r-block (<- val (r-call + %r:3) + (r-block (<- val (r-call attr<- val "tzone" tz)) - tz) - val)))) - (<- Summary.POSIXlt (lambda (... na.rm) - (let ((val ()) - (tz ()) - (args ()) - (ok ())) - (r-block (<- ok (switch .Generic (*named* + tz) + val)))) + (<- Summary.POSIXlt (lambda (... na.rm) + (let ((val ()) + (tz ()) + (args ()) + (ok ())) + (r-block (<- ok (switch .Generic (*named* max *r-missing*) - (*named* min + (*named* min *r-missing*) - (*named* - range - *r-true*) - *r-false*)) - (if (r-call ! ok) - (r-call stop .Generic - " not defined for \"POSIXlt\" objects")) - (<- args (r-call list - r-dotdotdot)) - (<- tz (r-call do.call "check_tzones" - args)) - (<- args (r-call lapply args - as.POSIXct)) - (<- val (r-call do.call - .Generic (r-call + (*named* + range + *r-true*) + *r-false*)) + (if (r-call ! ok) + (r-call stop .Generic + " not defined for \"POSIXlt\" objects")) + (<- args (r-call list + r-dotdotdot)) + (<- tz (r-call do.call "check_tzones" + args)) + (<- args (r-call lapply args + as.POSIXct)) + (<- val (r-call do.call + .Generic (r-call c args (*named* na.rm na.rm)))) - (r-call as.POSIXlt (r-call + (r-call as.POSIXlt (r-call structure val (*named* class (r-call c "POSIXt" "POSIXct")) (*named* tzone tz))))))) - (<- "[.POSIXct" (lambda (x ... drop) - (let ((val ()) - (x ()) - (cl ()) - (drop ())) - (r-block (when (missing drop) - (<- drop *r-true*)) - (<- cl (r-call oldClass x)) - (r-block (<- x (r-call class<- + (<- "[.POSIXct" (lambda (x ... drop) + (let ((val ()) + (x ()) + (cl ()) + (drop ())) + (r-block (when (missing drop) + (<- drop *r-true*)) + (<- cl (r-call oldClass x)) + (r-block (<- x (r-call class<- x ())) - ()) - (<- val (r-call NextMethod "[")) - (r-block (<- val (r-call class<- + ()) + (<- val (r-call NextMethod "[")) + (r-block (<- val (r-call class<- val cl)) - cl) - (r-block (ref= %r:4 (r-call attr + cl) + (r-block (ref= %r:4 (r-call attr x "tzone")) - (<- val (r-call attr<- + (<- val (r-call attr<- val "tzone" %r:4)) - %r:4) - val)))) - (<- "[[.POSIXct" (lambda (x ... drop) - (let ((val ()) - (x ()) - (cl ()) - (drop ())) - (r-block (when (missing drop) - (<- drop *r-true*)) - (<- cl (r-call oldClass x)) - (r-block (<- x (r-call class<- + %r:4) + val)))) + (<- "[[.POSIXct" (lambda (x ... drop) + (let ((val ()) + (x ()) + (cl ()) + (drop ())) + (r-block (when (missing drop) + (<- drop *r-true*)) + (<- cl (r-call oldClass x)) + (r-block (<- x (r-call class<- x ())) - ()) - (<- val (r-call NextMethod "[[")) - (r-block (<- val (r-call - class<- val - cl)) - cl) - (r-block (ref= %r:5 (r-call + ()) + (<- val (r-call NextMethod "[[")) + (r-block (<- val (r-call + class<- val + cl)) + cl) + (r-block (ref= %r:5 (r-call attr x "tzone")) - (<- val (r-call attr<- + (<- val (r-call attr<- val "tzone" %r:5)) - %r:5) - val)))) - (<- "[<-.POSIXct" (lambda (x ... value) - (let ((x ()) - (tz ()) - (cl ()) - (value ())) - (r-block (if (r-call ! (r-call - as.logical (r-call + %r:5) + val)))) + (<- "[<-.POSIXct" (lambda (x ... value) + (let ((x ()) + (tz ()) + (cl ()) + (value ())) + (r-block (if (r-call ! (r-call + as.logical (r-call length value))) - (return x)) - (<- value (r-call as.POSIXct - value)) - (<- cl (r-call oldClass x)) - (<- tz (r-call attr x "tzone")) - (r-block (ref= %r:6 (r-block + (return x)) + (<- value (r-call as.POSIXct + value)) + (<- cl (r-call oldClass x)) + (<- tz (r-call attr x "tzone")) + (r-block (ref= %r:6 (r-block (<- value (r-call class<- value - ())) + ())) ())) - (<- x (r-call class<- + (<- x (r-call class<- x %r:6)) - %r:6) - (<- x (r-call NextMethod - .Generic)) - (r-block (<- x (r-call class<- + %r:6) + (<- x (r-call NextMethod + .Generic)) + (r-block (<- x (r-call class<- x cl)) - cl) - (r-block (<- x (r-call attr<- + cl) + (r-block (<- x (r-call attr<- x "tzone" tz)) - tz) - x)))) - (<- as.character.POSIXt (lambda (x ...) - (let () - (r-block (r-call format x - r-dotdotdot))))) - (<- as.data.frame.POSIXct as.data.frame.vector) - (<- is.na.POSIXlt (lambda (x) - (let () - (r-block (r-call is.na (r-call - as.POSIXct x)))))) - (<- c.POSIXct (lambda (... recursive) - (let ((recursive ())) - (r-block (when (missing recursive) - (<- recursive *r-false*)) - (r-call structure (r-call c (r-call + tz) + x)))) + (<- as.character.POSIXt (lambda (x ...) + (let () + (r-block (r-call format x + r-dotdotdot))))) + (<- as.data.frame.POSIXct as.data.frame.vector) + (<- is.na.POSIXlt (lambda (x) + (let () + (r-block (r-call is.na (r-call + as.POSIXct x)))))) + (<- c.POSIXct (lambda (... recursive) + (let ((recursive ())) + (r-block (when (missing recursive) + (<- recursive *r-false*)) + (r-call structure (r-call c (r-call unlist (r-call lapply (r-call list r-dotdotdot) unclass))) - (*named* class (r-call c + (*named* class (r-call c "POSIXt" "POSIXct"))))))) - (<- c.POSIXlt (lambda (... recursive) - (let ((recursive ())) - (r-block (when (missing recursive) - (<- recursive *r-false*)) - (r-call as.POSIXlt (r-call do.call + (<- c.POSIXlt (lambda (... recursive) + (let ((recursive ())) + (r-block (when (missing recursive) + (<- recursive *r-false*)) + (r-call as.POSIXlt (r-call do.call "c" (r-call lapply (r-call list r-dotdotdot) as.POSIXct))))))) - (<- all.equal.POSIXct (lambda (target current ... scale) - (let ((scale ())) - (r-block (when (missing scale) - (<- scale 1)) - (r-call check_tzones - target current) - (r-call NextMethod "all.equal"))))) - (<- ISOdatetime (lambda (year month day hour min sec tz) - (let ((x ()) - (tz ())) - (r-block (when (missing tz) - (<- tz "")) - (<- x (r-call paste year month - day hour min sec - (*named* sep "-"))) - (r-call as.POSIXct (r-call - strptime x - "%Y-%m-%d-%H-%M-%OS" - (*named* tz + (<- all.equal.POSIXct (lambda (target current ... scale) + (let ((scale ())) + (r-block (when (missing scale) + (<- scale 1)) + (r-call check_tzones + target current) + (r-call NextMethod "all.equal"))))) + (<- ISOdatetime (lambda (year month day hour min sec tz) + (let ((x ()) + (tz ())) + (r-block (when (missing tz) + (<- tz "")) + (<- x (r-call paste year month + day hour min sec + (*named* sep "-"))) + (r-call as.POSIXct (r-call + strptime x + "%Y-%m-%d-%H-%M-%OS" + (*named* tz tz)) - (*named* tz tz)))))) - (<- ISOdate (lambda (year month day hour min sec tz) - (let ((tz ()) - (sec ()) - (min ()) - (hour ())) - (r-block (when (missing hour) - (<- hour 12)) - (when (missing min) - (<- min 0)) - (when (missing sec) - (<- sec 0)) - (when (missing tz) - (<- tz "GMT")) - (r-call ISOdatetime year month day - hour min sec tz))))) - (<- as.matrix.POSIXlt (lambda (x ...) - (let () - (r-block (r-call as.matrix (r-call + (*named* tz tz)))))) + (<- ISOdate (lambda (year month day hour min sec tz) + (let ((tz ()) + (sec ()) + (min ()) + (hour ())) + (r-block (when (missing hour) + (<- hour 12)) + (when (missing min) + (<- min 0)) + (when (missing sec) + (<- sec 0)) + (when (missing tz) + (<- tz "GMT")) + (r-call ISOdatetime year month day + hour min sec tz))))) + (<- as.matrix.POSIXlt (lambda (x ...) + (let () + (r-block (r-call as.matrix (r-call as.data.frame (r-call unclass x)) - r-dotdotdot))))) - (<- mean.POSIXct (lambda (x ...) - (let () - (r-block (r-call structure (r-call mean + r-dotdotdot))))) + (<- mean.POSIXct (lambda (x ...) + (let () + (r-block (r-call structure (r-call mean (r-call unclass x) r-dotdotdot) - (*named* class (r-call + (*named* class (r-call c "POSIXt" "POSIXct")) - (*named* tzone (r-call + (*named* tzone (r-call attr x "tzone"))))))) - (<- mean.POSIXlt (lambda (x ...) - (let () - (r-block (r-call as.POSIXlt (r-call mean + (<- mean.POSIXlt (lambda (x ...) + (let () + (r-block (r-call as.POSIXlt (r-call mean (r-call as.POSIXct x) r-dotdotdot)))))) - (<- difftime (lambda (time1 time2 tz units) - (let ((zz ()) - (z ()) - (time2 ()) - (time1 ()) - (units ()) - (tz ())) - (r-block (when (missing tz) - (<- tz "")) - (when (missing units) - (<- units (r-call c "auto" "secs" - "mins" "hours" - "days" "weeks"))) - (<- time1 (r-call as.POSIXct time1 - (*named* tz tz))) - (<- time2 (r-call as.POSIXct time2 - (*named* tz tz))) - (<- z (r-call - (r-call unclass - time1) - (r-call unclass time2))) - (<- units (r-call match.arg units)) - (if (r-call == units "auto") - (r-block (if (r-call all (r-call + (<- difftime (lambda (time1 time2 tz units) + (let ((zz ()) + (z ()) + (time2 ()) + (time1 ()) + (units ()) + (tz ())) + (r-block (when (missing tz) + (<- tz "")) + (when (missing units) + (<- units (r-call c "auto" "secs" + "mins" "hours" + "days" "weeks"))) + (<- time1 (r-call as.POSIXct time1 + (*named* tz tz))) + (<- time2 (r-call as.POSIXct time2 + (*named* tz tz))) + (<- z (r-call - (r-call unclass + time1) + (r-call unclass time2))) + (<- units (r-call match.arg units)) + (if (r-call == units "auto") + (r-block (if (r-call all (r-call is.na z)) - (<- units "secs") - (r-block (<- zz (r-call + (<- units "secs") + (r-block (<- zz (r-call min (r-call abs z) (*named* na.rm *r-true*))) (if (|\|\|| (r-call is.na zz) (r-call < zz 60)) (<- units "secs") (if (r-call < zz 3600) - (<- units "mins") - (if (r-call < zz 86400) - (<- units "hours") - (<- units "days")))))))) - (switch units (*named* secs (r-call + (<- units "mins") + (if (r-call < zz 86400) + (<- units "hours") + (<- units "days")))))))) + (switch units (*named* secs (r-call structure z (*named* units "secs") (*named* class "difftime"))) - (*named* mins (r-call - structure (r-call + (*named* mins (r-call + structure (r-call / z 60) - (*named* - units "mins") - (*named* - class "difftime"))) - (*named* hours (r-call - structure - (r-call / + (*named* + units "mins") + (*named* + class "difftime"))) + (*named* hours (r-call + structure + (r-call / z 3600) - (*named* + (*named* units "hours") - (*named* + (*named* class "difftime"))) - (*named* days (r-call - structure (r-call + (*named* days (r-call + structure (r-call / z 86400) - (*named* - units "days") - (*named* - class "difftime"))) - (*named* weeks (r-call - structure - (r-call / + (*named* + units "days") + (*named* + class "difftime"))) + (*named* weeks (r-call + structure + (r-call / z (r-call * 7 86400)) - (*named* + (*named* units "weeks") - (*named* + (*named* class "difftime")))))))) - (<- as.difftime (lambda (tim format units) - (let ((units ()) - (format ())) - (r-block (when (missing format) - (<- format "%X")) - (when (missing units) - (<- units "auto")) - (if (r-call inherits tim "difftime") - (return tim)) - (if (r-call is.character tim) - (r-block (r-call difftime (r-call + (<- as.difftime (lambda (tim format units) + (let ((units ()) + (format ())) + (r-block (when (missing format) + (<- format "%X")) + (when (missing units) + (<- units "auto")) + (if (r-call inherits tim "difftime") + (return tim)) + (if (r-call is.character tim) + (r-block (r-call difftime (r-call strptime tim (*named* format format)) - (r-call + (r-call strptime "0:0:0" (*named* format "%X")) - (*named* + (*named* units units))) - (r-block (if (r-call ! (r-call + (r-block (if (r-call ! (r-call is.numeric tim)) - (r-call stop "'tim' is not character or numeric")) - (if (r-call == + (r-call stop "'tim' is not character or numeric")) + (if (r-call == units "auto") - (r-call stop "need explicit units for numeric conversion")) - (if (r-call ! (r-call + (r-call stop "need explicit units for numeric conversion")) + (if (r-call ! (r-call %in% units (r-call c "secs" "mins" "hours" "days" "weeks"))) - (r-call stop "invalid units specified")) - (r-call structure - tim (*named* + (r-call stop "invalid units specified")) + (r-call structure + tim (*named* units units) - (*named* + (*named* class "difftime")))))))) - (<- units (lambda (x) - (let () (r-block (r-call UseMethod "units"))))) - (<- "units<-" (lambda (x value) - (let () (r-block (r-call UseMethod "units<-"))))) - (<- units.difftime (lambda (x) - (let () - (r-block (r-call attr x "units"))))) - (<- "units<-.difftime" (lambda (x value) - (let ((newx ()) - (sc ()) - (from ())) - (r-block (<- from (r-call units x)) - (if (r-call == from value) - (return x)) - (if (r-call ! (r-call + (<- units (lambda (x) + (let () (r-block (r-call UseMethod "units"))))) + (<- "units<-" (lambda (x value) + (let () (r-block (r-call UseMethod "units<-"))))) + (<- units.difftime (lambda (x) + (let () + (r-block (r-call attr x "units"))))) + (<- "units<-.difftime" (lambda (x value) + (let ((newx ()) + (sc ()) + (from ())) + (r-block (<- from (r-call units x)) + (if (r-call == from value) + (return x)) + (if (r-call ! (r-call %in% value (r-call c "secs" "mins" "hours" "days" "weeks"))) - (r-call stop "invalid units specified")) - (<- sc (r-call cumprod (r-call + (r-call stop "invalid units specified")) + (<- sc (r-call cumprod (r-call c (*named* secs 1) (*named* mins 60) (*named* hours 60) (*named* days 24) (*named* weeks 7)))) - (<- newx (r-call / (r-call + (<- newx (r-call / (r-call * (r-call as.vector x) (r-call r-index sc from)) (r-call r-index sc value))) - (r-call structure newx - (*named* units + (r-call structure newx + (*named* units value) - (*named* class "difftime")))))) - (<- as.double.difftime (lambda (x units ...) - (let ((x ()) - (units ())) - (r-block (when (missing units) - (<- units "auto")) - (if (r-call != units "auto") - (r-block (<- x (r-call + (*named* class "difftime")))))) + (<- as.double.difftime (lambda (x units ...) + (let ((x ()) + (units ())) + (r-block (when (missing units) + (<- units "auto")) + (if (r-call != units "auto") + (r-block (<- x (r-call units<- x units)) - units)) - (r-call as.double (r-call + units)) + (r-call as.double (r-call as.vector x)))))) - (<- as.data.frame.difftime - as.data.frame.vector) - (<- format.difftime (lambda (x ...) - (let () - (r-block (r-call paste (r-call format + (<- as.data.frame.difftime + as.data.frame.vector) + (<- format.difftime (lambda (x ...) + (let () + (r-block (r-call paste (r-call format (r-call unclass x) r-dotdotdot) - (r-call units x)))))) - (<- print.difftime (lambda (x digits ...) - (let ((y ()) - (digits ())) - (r-block (when (missing digits) - (<- digits (r-call - getOption - "digits"))) - (if (|\|\|| (r-call is.array + (r-call units x)))))) + (<- print.difftime (lambda (x digits ...) + (let ((y ()) + (digits ())) + (r-block (when (missing digits) + (<- digits (r-call + getOption + "digits"))) + (if (|\|\|| (r-call is.array x) - (r-call > (r-call + (r-call > (r-call length x) 1)) - (r-block (r-call cat "Time differences in " + (r-block (r-call cat "Time differences in " (r-call attr x "units") "\n" (*named* sep "")) - (<- y (r-call + (<- y (r-call unclass x)) - (r-block (<- y + (r-block (<- y (r-call attr<- y "units" - ())) + ())) ()) - (r-call print y)) - (r-call cat "Time difference of " - (r-call format (r-call + (r-call print y)) + (r-call cat "Time difference of " + (r-call format (r-call unclass x) (*named* digits digits)) - " " (r-call attr + " " (r-call attr x "units") - "\n" (*named* sep + "\n" (*named* sep ""))) - (r-call invisible x))))) - (<- round.difftime (lambda (x digits ...) - (let ((units ()) - (digits ())) - (r-block (when (missing digits) - (<- digits 0)) - (<- units (r-call attr x "units")) - (r-call structure (r-call + (r-call invisible x))))) + (<- round.difftime (lambda (x digits ...) + (let ((units ()) + (digits ())) + (r-block (when (missing digits) + (<- digits 0)) + (<- units (r-call attr x "units")) + (r-call structure (r-call NextMethod) - (*named* units units) - (*named* class "difftime")))))) - (<- "[.difftime" (lambda (x ... drop) - (let ((val ()) - (x ()) - (cl ()) - (drop ())) - (r-block (when (missing drop) - (<- drop *r-true*)) - (<- cl (r-call oldClass x)) - (r-block (<- x (r-call class<- + (*named* units units) + (*named* class "difftime")))))) + (<- "[.difftime" (lambda (x ... drop) + (let ((val ()) + (x ()) + (cl ()) + (drop ())) + (r-block (when (missing drop) + (<- drop *r-true*)) + (<- cl (r-call oldClass x)) + (r-block (<- x (r-call class<- x ())) - ()) - (<- val (r-call NextMethod "[")) - (r-block (<- val (r-call - class<- val - cl)) - cl) - (r-block (ref= %r:7 (r-call + ()) + (<- val (r-call NextMethod "[")) + (r-block (<- val (r-call + class<- val + cl)) + cl) + (r-block (ref= %r:7 (r-call attr x "units")) - (<- val (r-call attr<- + (<- val (r-call attr<- val "units" %r:7)) - %r:7) - val)))) - (<- Ops.difftime (lambda (e1 e2) - (let ((u1 ()) - (e2 ()) - (boolean ()) - (e1 ()) - (coerceTimeUnit ())) - (r-block (<- coerceTimeUnit (lambda (x) + %r:7) + val)))) + (<- Ops.difftime (lambda (e1 e2) + (let ((u1 ()) + (e2 ()) + (boolean ()) + (e1 ()) + (coerceTimeUnit ())) + (r-block (<- coerceTimeUnit (lambda (x) (let () (r-block (switch (r-call attr x "units") - (*named* secs x) - (*named* mins (r-call * 60 x)) - (*named* hours (r-call * (r-call * 60 60) x)) - (*named* days (r-call * (r-call * (r-call * 60 60) - 24) - x)) - (*named* weeks (r-call * (r-call * (r-call * (r-call + (*named* secs x) + (*named* mins (r-call * 60 x)) + (*named* hours (r-call * (r-call * 60 60) x)) + (*named* days (r-call * (r-call * (r-call * 60 60) + 24) + x)) + (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) 24) - 7) - x))))))) - (if (r-call == (r-call nargs) - 1) - (r-block (switch .Generic + 7) + x))))))) + (if (r-call == (r-call nargs) + 1) + (r-block (switch .Generic (*named* + (r-block)) (*named* - (r-block (r-block (ref= %r:8 (r-call - (r-call unclass e1))) - (<- e1 (r-call r-index<- - e1 - *r-missing* - %r:8)) - %r:8))) + (<- e1 (r-call r-index<- + e1 + *r-missing* + %r:8)) + %r:8))) (r-call stop "unary" .Generic - " not defined for \"difftime\" objects")) - (return e1))) - (<- boolean (switch .Generic (*named* + " not defined for \"difftime\" objects")) + (return e1))) + (<- boolean (switch .Generic (*named* < *r-missing*) - (*named* > + (*named* > *r-missing*) - (*named* == + (*named* == *r-missing*) - (*named* != + (*named* != *r-missing*) - (*named* <= + (*named* <= *r-missing*) - (*named* >= + (*named* >= *r-true*) - *r-false*)) - (if boolean (r-block (if (&& (r-call + *r-false*)) + (if boolean (r-block (if (&& (r-call inherits e1 "difftime") (r-call inherits e2 "difftime")) (r-block (<- e1 (r-call coerceTimeUnit e1)) - (<- e2 (r-call coerceTimeUnit e2)))) + (<- e2 (r-call coerceTimeUnit e2)))) (r-call NextMethod .Generic)) - (if (|\|\|| (r-call == + (if (|\|\|| (r-call == .Generic "+") - (r-call == + (r-call == .Generic "-")) - (r-block (if (&& (r-call + (r-block (if (&& (r-call inherits e1 "difftime") (r-call ! (r-call inherits e2 "difftime"))) (return (r-call structure (r-call NextMethod .Generic) - (*named* units (r-call attr e1 "units")) - (*named* class "difftime")))) - (if (&& (r-call + (*named* units (r-call attr e1 "units")) + (*named* class "difftime")))) + (if (&& (r-call ! (r-call inherits e1 "difftime")) (r-call inherits e2 "difftime")) (return (r-call structure (r-call NextMethod .Generic) - (*named* units (r-call attr e2 "units")) - (*named* class "difftime")))) - (<- u1 (r-call + (*named* units (r-call attr e2 "units")) + (*named* class "difftime")))) + (<- u1 (r-call attr e1 "units")) - (if (r-call == + (if (r-call == (r-call attr e2 "units") u1) (r-block (r-call structure (r-call NextMethod .Generic) - (*named* units u1) (*named* class "difftime"))) + (*named* units u1) (*named* class "difftime"))) (r-block (<- e1 (r-call coerceTimeUnit e1)) - (<- e2 (r-call coerceTimeUnit e2)) - (r-call structure (r-call NextMethod .Generic) - (*named* units "secs") - (*named* class "difftime"))))) - (r-block (r-call stop + (<- e2 (r-call coerceTimeUnit e2)) + (r-call structure (r-call NextMethod .Generic) + (*named* units "secs") + (*named* class "difftime"))))) + (r-block (r-call stop .Generic "not defined for \"difftime\" objects")))))))) - (<- "*.difftime" (lambda (e1 e2) - (let ((e2 ()) - (e1 ()) - (tmp ())) - (r-block (if (&& (r-call inherits e1 "difftime") - (r-call inherits e2 "difftime")) - (r-call stop "both arguments of * cannot be \"difftime\" objects")) - (if (r-call inherits e2 "difftime") - (r-block (<- tmp e1) - (<- e1 e2) - (<- e2 tmp))) - (r-call structure (r-call * e2 + (<- "*.difftime" (lambda (e1 e2) + (let ((e2 ()) + (e1 ()) + (tmp ())) + (r-block (if (&& (r-call inherits e1 "difftime") + (r-call inherits e2 "difftime")) + (r-call stop "both arguments of * cannot be \"difftime\" objects")) + (if (r-call inherits e2 "difftime") + (r-block (<- tmp e1) + (<- e1 e2) + (<- e2 tmp))) + (r-call structure (r-call * e2 (r-call unclass e1)) - (*named* units (r-call + (*named* units (r-call attr e1 "units")) - (*named* class "difftime")))))) - (<- "/.difftime" (lambda (e1 e2) - (let () - (r-block (if (r-call inherits e2 "difftime") - (r-call stop "second argument of / cannot be a \"difftime\" object")) - (r-call structure (r-call / (r-call + (*named* class "difftime")))))) + (<- "/.difftime" (lambda (e1 e2) + (let () + (r-block (if (r-call inherits e2 "difftime") + (r-call stop "second argument of / cannot be a \"difftime\" object")) + (r-call structure (r-call / (r-call unclass e1) e2) - (*named* units (r-call + (*named* units (r-call attr e1 "units")) - (*named* class "difftime")))))) - (<- Math.difftime (lambda (x ...) - (let () - (r-block (r-call stop .Generic - "not defined for \"difftime\" objects"))))) - (<- mean.difftime (lambda (x ... na.rm) - (let ((args ()) - (coerceTimeUnit ()) - (na.rm ())) - (r-block (when (missing na.rm) - (<- na.rm *r-false*)) - (<- coerceTimeUnit (lambda (x) + (*named* class "difftime")))))) + (<- Math.difftime (lambda (x ...) + (let () + (r-block (r-call stop .Generic + "not defined for \"difftime\" objects"))))) + (<- mean.difftime (lambda (x ... na.rm) + (let ((args ()) + (coerceTimeUnit ()) + (na.rm ())) + (r-block (when (missing na.rm) + (<- na.rm *r-false*)) + (<- coerceTimeUnit (lambda (x) (let () (r-block (r-call as.vector (switch (r-call attr x "units") - (*named* secs x) - (*named* mins (r-call * 60 x)) - (*named* hours (r-call * (r-call + (*named* secs x) + (*named* mins (r-call * 60 x)) + (*named* hours (r-call * (r-call * 60 60) - x)) - (*named* days (r-call * (r-call * + x)) + (*named* days (r-call * (r-call * (r-call * 60 60) 24) - x)) - (*named* weeks (r-call * (r-call + x)) + (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) 24) 7) - x)))))))) - (if (r-call length (r-call + x)))))))) + (if (r-call length (r-call list r-dotdotdot)) - (r-block (<- args (r-call + (r-block (<- args (r-call c (r-call lapply (r-call list x r-dotdotdot) coerceTimeUnit) (*named* na.rm na.rm))) - (r-call structure + (r-call structure (r-call do.call "mean" args) (*named* units "secs") (*named* class "difftime"))) - (r-block (r-call structure + (r-block (r-call structure (r-call mean (r-call as.vector x) - (*named* na.rm na.rm)) + (*named* na.rm na.rm)) (*named* units (r-call attr x "units")) (*named* class "difftime")))))))) - (<- Summary.difftime (lambda (... na.rm) - (let ((args ()) - (ok ()) - (coerceTimeUnit ())) - (r-block (<- coerceTimeUnit (lambda (x) + (<- Summary.difftime (lambda (... na.rm) + (let ((args ()) + (ok ()) + (coerceTimeUnit ())) + (r-block (<- coerceTimeUnit (lambda (x) (let () (r-block (r-call as.vector (switch (r-call attr x "units") - (*named* secs x) - (*named* mins (r-call * 60 x)) - (*named* hours (r-call * (r-call + (*named* secs x) + (*named* mins (r-call * 60 x)) + (*named* hours (r-call * (r-call * 60 60) - x)) - (*named* days (r-call * (r-call * + x)) + (*named* days (r-call * (r-call * (r-call * 60 60) 24) - x)) - (*named* weeks (r-call * (r-call + x)) + (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) 24) 7) - x)))))))) - (<- ok (switch .Generic (*named* + x)))))))) + (<- ok (switch .Generic (*named* max *r-missing*) - (*named* min + (*named* min *r-missing*) - (*named* - range - *r-true*) - *r-false*)) - (if (r-call ! ok) - (r-call stop .Generic - " not defined for \"difftime\" objects")) - (<- args (r-call c (r-call + (*named* + range + *r-true*) + *r-false*)) + (if (r-call ! ok) + (r-call stop .Generic + " not defined for \"difftime\" objects")) + (<- args (r-call c (r-call lapply (r-call list r-dotdotdot) coerceTimeUnit) (*named* na.rm na.rm))) - (r-call structure (r-call + (r-call structure (r-call do.call .Generic args) - (*named* units "secs") - (*named* class "difftime")))))) - (<- seq.POSIXt (lambda (from to by length.out along.with ...) - (let ((mon ()) - (yr ()) - (r1 ()) - (by2 ()) - (by ()) - (valid ()) - (res ()) - (to ()) - (from ()) - (status ()) - (tz ()) - (cfrom ()) - (along.with ()) - (length.out ())) - (r-block (when (missing length.out) - (<- length.out ())) - (when (missing along.with) - (<- along.with ())) - (if (missing from) - (r-call stop "'from' must be specified")) - (if (r-call ! (r-call inherits - from "POSIXt")) - (r-call stop "'from' must be a POSIXt object")) - (<- cfrom (r-call as.POSIXct from)) - (if (r-call != (r-call length + (*named* units "secs") + (*named* class "difftime")))))) + (<- seq.POSIXt (lambda (from to by length.out along.with ...) + (let ((mon ()) + (yr ()) + (r1 ()) + (by2 ()) + (by ()) + (valid ()) + (res ()) + (to ()) + (from ()) + (status ()) + (tz ()) + (cfrom ()) + (along.with ()) + (length.out ())) + (r-block (when (missing length.out) + (<- length.out ())) + (when (missing along.with) + (<- along.with ())) + (if (missing from) + (r-call stop "'from' must be specified")) + (if (r-call ! (r-call inherits + from "POSIXt")) + (r-call stop "'from' must be a POSIXt object")) + (<- cfrom (r-call as.POSIXct from)) + (if (r-call != (r-call length cfrom) - 1) - (r-call stop "'from' must be of length 1")) - (<- tz (r-call attr cfrom "tzone")) - (if (r-call ! (missing to)) - (r-block (if (r-call ! (r-call + 1) + (r-call stop "'from' must be of length 1")) + (<- tz (r-call attr cfrom "tzone")) + (if (r-call ! (missing to)) + (r-block (if (r-call ! (r-call inherits to "POSIXt")) - (r-call stop "'to' must be a POSIXt object")) - (if (r-call != (r-call + (r-call stop "'to' must be a POSIXt object")) + (if (r-call != (r-call length (r-call as.POSIXct to)) 1) - (r-call stop "'to' must be of length 1")))) - (if (r-call ! (missing along.with)) - (r-block (<- length.out (r-call + (r-call stop "'to' must be of length 1")))) + (if (r-call ! (missing along.with)) + (r-block (<- length.out (r-call length along.with))) - (if (r-call ! (r-call is.null + (if (r-call ! (r-call is.null length.out)) - (r-block (if (r-call != + (r-block (if (r-call != (r-call length length.out) 1) - (r-call stop + (r-call stop "'length.out' must be of length 1")) - (<- length.out - (r-call - ceiling - length.out))))) - (<- status (r-call c (r-call ! (missing + (<- length.out + (r-call + ceiling + length.out))))) + (<- status (r-call c (r-call ! (missing to)) - (r-call ! (missing + (r-call ! (missing by)) - (r-call ! (r-call + (r-call ! (r-call is.null length.out)))) - (if (r-call != (r-call sum status) - 2) - (r-call stop "exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified")) - (if (missing by) - (r-block (<- from (r-call + (if (r-call != (r-call sum status) + 2) + (r-call stop "exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified")) + (if (missing by) + (r-block (<- from (r-call unclass cfrom)) - (<- to (r-call - unclass (r-call + (<- to (r-call + unclass (r-call as.POSIXct to))) - (<- res (r-call - seq.int - from to (*named* + (<- res (r-call + seq.int + from to (*named* length.out length.out))) - (return (r-call - structure - res (*named* + (return (r-call + structure + res (*named* class (r-call c "POSIXt" "POSIXct")) - (*named* + (*named* tzone tz))))) - (if (r-call != (r-call length by) - 1) - (r-call stop "'by' must be of length 1")) - (<- valid 0) - (if (r-call inherits by "difftime") - (r-block (<- by (r-call * (switch + (if (r-call != (r-call length by) + 1) + (r-call stop "'by' must be of length 1")) + (<- valid 0) + (if (r-call inherits by "difftime") + (r-block (<- by (r-call * (switch (r-call attr by "units") (*named* secs 1) (*named* mins 60) (*named* hours 3600) (*named* days 86400) (*named* weeks (r-call * 7 86400))) (r-call unclass by)))) - (if (r-call is.character by) - (r-block (<- by2 (r-call + (if (r-call is.character by) + (r-block (<- by2 (r-call r-aref (r-call strsplit by " " - (*named* fixed *r-true*)) + (*named* fixed *r-true*)) 1)) - (if (|\|\|| (r-call + (if (|\|\|| (r-call > (r-call length by2) 2) (r-call < (r-call length by2) 1)) - (r-call stop + (r-call stop "invalid 'by' string")) - (<- valid (r-call + (<- valid (r-call pmatch (r-call r-index by2 - (r-call length by2)) + (r-call length by2)) (r-call c "secs" "mins" "hours" "days" "weeks" "months" "years" "DSTdays"))) - (if (r-call - is.na valid) - (r-call stop + (if (r-call + is.na valid) + (r-call stop "invalid string for 'by'")) - (if (r-call <= + (if (r-call <= valid 5) - (r-block (<- + (r-block (<- by (r-call r-index (r-call c 1 60 3600 86400 - (r-call * 7 86400)) - valid)) + (r-call * 7 86400)) + valid)) (if (r-call == (r-call length by2) 2) (<- by (r-call * by - (r-call as.integer (r-call + (r-call as.integer (r-call r-index by2 1)))))) - (<- by (if + (<- by (if (r-call == (r-call length by2) 2) (r-call as.integer (r-call r-index by2 1)) 1)))) - (if (r-call ! (r-call + (if (r-call ! (r-call is.numeric by)) - (r-call stop "invalid mode for 'by'")))) - (if (r-call is.na by) - (r-call stop "'by' is NA")) - (if (r-call <= valid 5) - (r-block (<- from (r-call + (r-call stop "invalid mode for 'by'")))) + (if (r-call is.na by) + (r-call stop "'by' is NA")) + (if (r-call <= valid 5) + (r-block (<- from (r-call unclass (r-call as.POSIXct from))) - (if (r-call ! (r-call + (if (r-call ! (r-call is.null length.out)) - (<- res (r-call + (<- res (r-call seq.int from (*named* by by) (*named* length.out length.out))) - (r-block (<- to + (r-block (<- to (r-call unclass (r-call as.POSIXct to))) (<- res (r-call + (r-call seq.int 0 - (r-call - to from) by) - from)))) - (return (r-call - structure - res (*named* + (r-call - to from) by) + from)))) + (return (r-call + structure + res (*named* class (r-call c "POSIXt" "POSIXct")) - (*named* + (*named* tzone tz)))) - (r-block (<- r1 (r-call - as.POSIXlt - from)) - (if (r-call == valid + (r-block (<- r1 (r-call + as.POSIXlt + from)) + (if (r-call == valid 7) - (r-block (if (missing + (r-block (if (missing to) (r-block (<- yr (r-call seq.int (r-call r-aref r1 - (index-in-strlist year (r-call attr + (index-in-strlist year (r-call attr r1 #0#))) - (*named* by by) - (*named* length length.out)))) + (*named* by by) + (*named* length length.out)))) (r-block (<- to (r-call as.POSIXlt to)) - (<- yr (r-call seq.int (r-call r-aref r1 - (index-in-strlist year (r-call attr + (<- yr (r-call seq.int (r-call r-aref r1 + (index-in-strlist year (r-call attr r1 #0#))) - (r-call r-aref to - (index-in-strlist year (r-call attr to #0#))) - by)))) + (r-call r-aref to + (index-in-strlist year (r-call attr to #0#))) + by)))) (r-block (<- r1 (r-call r-aref<- r1 - (index-in-strlist year (r-call attr r1 #0#)) yr)) - yr) + (index-in-strlist year (r-call attr r1 #0#)) yr)) + yr) (r-block (ref= %r:9 (r-call - 1)) (<- r1 (r-call r-aref<- r1 - (index-in-strlist isdst (r-call + (index-in-strlist isdst (r-call attr r1 #0#)) - %r:9)) - %r:9) + %r:9)) + %r:9) (<- res (r-call as.POSIXct r1))) - (if (r-call == + (if (r-call == valid 6) - (r-block (if + (r-block (if (missing to) (r-block (<- mon (r-call seq.int (r-call r-aref r1 - (index-in-strlist mon + (index-in-strlist mon (r-call attr r1 #0#))) - (*named* by by) - (*named* length length.out)))) + (*named* by by) + (*named* length length.out)))) (r-block (<- to (r-call as.POSIXlt to)) - (<- mon (r-call seq.int (r-call r-aref r1 - (index-in-strlist mon (r-call attr + (<- mon (r-call seq.int (r-call r-aref r1 + (index-in-strlist mon (r-call attr r1 #0#))) - (r-call + (r-call * 12 - (r-call - (r-call r-aref to - (index-in-strlist - year (r-call + (r-call + (r-call * 12 + (r-call - (r-call r-aref to + (index-in-strlist + year (r-call attr to #0#))) - (r-call r-aref r1 - (index-in-strlist - year (r-call attr + (r-call r-aref r1 + (index-in-strlist + year (r-call attr r1 #0#))))) - (r-call r-aref to - (index-in-strlist mon (r-call attr + (r-call r-aref to + (index-in-strlist mon (r-call attr to #0#)))) - by)))) + by)))) (r-block (<- r1 (r-call r-aref<- r1 - (index-in-strlist mon (r-call attr r1 #0#)) mon)) - mon) + (index-in-strlist mon (r-call attr r1 #0#)) mon)) + mon) (r-block (ref= %r:10 (r-call - 1)) (<- r1 (r-call r-aref<- r1 - (index-in-strlist isdst (r-call + (index-in-strlist isdst (r-call attr r1 #0#)) - %r:10)) - %r:10) + %r:10)) + %r:10) (<- res (r-call as.POSIXct r1))) - (if (r-call + (if (r-call == valid 8) (r-block (if (r-call ! (missing to)) (r-block (<- length.out (r-call + 2 (r-call floor (r-call / (r-call - (r-call unclass (r-call as.POSIXct to)) - (r-call unclass (r-call as.POSIXct from))) - 86400)))))) - (r-block (ref= %r:11 (r-call seq.int (r-call r-aref r1 - (index-in-strlist mday + (r-call unclass (r-call as.POSIXct from))) + 86400)))))) + (r-block (ref= %r:11 (r-call seq.int (r-call r-aref r1 + (index-in-strlist mday (r-call attr r1 #0#))) - (*named* by by) - (*named* length length.out))) - (<- r1 (r-call r-aref<- r1 - (index-in-strlist mday (r-call attr r1 #0#)) - %r:11)) - %r:11) - (r-block (ref= %r:12 (r-call - 1)) - (<- r1 (r-call r-aref<- r1 - (index-in-strlist isdst (r-call attr r1 #0#)) - %r:12)) - %r:12) - (<- res (r-call as.POSIXct r1)) - (if (r-call ! (missing to)) (<- res (r-call r-index res - (r-call <= res - (r-call - as.POSIXct to))))))))) - (return res))))))) - (<- cut.POSIXt (lambda (x breaks labels start.on.monday right - ...) - (let ((res ()) - (maxx ()) - (incr ()) - (start ()) - (valid ()) - (by2 ()) - (breaks ()) - (x ()) - (right ()) - (start.on.monday ()) - (labels ())) - (r-block (when (missing labels) - (<- labels ())) - (when (missing start.on.monday) - (<- start.on.monday - *r-true*)) - (when (missing right) - (<- right *r-false*)) - (if (r-call ! (r-call inherits x - "POSIXt")) - (r-call stop "'x' must be a date-time object")) - (<- x (r-call as.POSIXct x)) - (if (r-call inherits breaks "POSIXt") - (r-block (<- breaks (r-call + (*named* by by) + (*named* length length.out))) + (<- r1 (r-call r-aref<- r1 + (index-in-strlist mday (r-call attr r1 #0#)) + %r:11)) + %r:11) + (r-block (ref= %r:12 (r-call - 1)) + (<- r1 (r-call r-aref<- r1 + (index-in-strlist isdst (r-call attr r1 #0#)) + %r:12)) + %r:12) + (<- res (r-call as.POSIXct r1)) + (if (r-call ! (missing to)) (<- res (r-call r-index res + (r-call <= res + (r-call + as.POSIXct to))))))))) + (return res))))))) + (<- cut.POSIXt (lambda (x breaks labels start.on.monday right + ...) + (let ((res ()) + (maxx ()) + (incr ()) + (start ()) + (valid ()) + (by2 ()) + (breaks ()) + (x ()) + (right ()) + (start.on.monday ()) + (labels ())) + (r-block (when (missing labels) + (<- labels ())) + (when (missing start.on.monday) + (<- start.on.monday + *r-true*)) + (when (missing right) + (<- right *r-false*)) + (if (r-call ! (r-call inherits x + "POSIXt")) + (r-call stop "'x' must be a date-time object")) + (<- x (r-call as.POSIXct x)) + (if (r-call inherits breaks "POSIXt") + (r-block (<- breaks (r-call as.POSIXct breaks))) - (if (&& (r-call is.numeric - breaks) - (r-call == (r-call + (if (&& (r-call is.numeric + breaks) + (r-call == (r-call length breaks) - 1)) - (r-block) - (if (&& (r-call - is.character - breaks) - (r-call == (r-call + 1)) + (r-block) + (if (&& (r-call + is.character + breaks) + (r-call == (r-call length breaks) 1)) - (r-block (<- by2 (r-call + (r-block (<- by2 (r-call r-aref (r-call strsplit breaks " " - (*named* fixed *r-true*)) + (*named* fixed *r-true*)) 1)) - (if (|\|\|| + (if (|\|\|| (r-call > (r-call length by2) 2) (r-call < (r-call length by2) 1)) (r-call stop "invalid specification of 'breaks'")) - (<- valid (r-call + (<- valid (r-call pmatch (r-call r-index by2 - (r-call length by2)) + (r-call length by2)) (r-call c "secs" "mins" "hours" "days" "weeks" "months" "years" "DSTdays"))) - (if (r-call + (if (r-call is.na valid) (r-call stop "invalid specification of 'breaks'")) - (<- start (r-call + (<- start (r-call as.POSIXlt (r-call min x - (*named* na.rm *r-true*)))) - (<- incr 1) - (if (r-call + (*named* na.rm *r-true*)))) + (<- incr 1) + (if (r-call > valid 1) (r-block (r-block (<- start (r-call r-aref<- start - (index-in-strlist sec (r-call attr start - #0#)) - 0)) - 0) - (<- incr 59.990000000000002))) - (if (r-call + (index-in-strlist sec (r-call attr start + #0#)) + 0)) + 0) + (<- incr 59.990000000000002))) + (if (r-call > valid 2) (r-block (r-block (<- start (r-call r-aref<- start - (index-in-strlist min (r-call attr start - #0#)) - 0)) - 0) - (<- incr (r-call - 3600 1)))) - (if (r-call + (index-in-strlist min (r-call attr start + #0#)) + 0)) + 0) + (<- incr (r-call - 3600 1)))) + (if (r-call > valid 3) (r-block (r-block (<- start (r-call r-aref<- start - (index-in-strlist hour (r-call attr start + (index-in-strlist hour (r-call attr start #0#)) - 0)) - 0) - (<- incr (r-call - 86400 1)))) - (if (r-call + 0)) + 0) + (<- incr (r-call - 86400 1)))) + (if (r-call == valid 5) (r-block (r-block (ref= %r:13 (r-call - (r-call r-aref start - (index-in-strlist mday (r-call + (index-in-strlist mday (r-call attr start #0#))) - (r-call r-aref start - (index-in-strlist wday (r-call + (r-call r-aref start + (index-in-strlist wday (r-call attr start #0#))))) - (<- start (r-call r-aref<- start - (index-in-strlist mday (r-call attr start + (<- start (r-call r-aref<- start + (index-in-strlist mday (r-call attr start #0#)) - %r:13)) - %r:13) - (if start.on.monday (r-block (ref= %r:14 (r-call + (r-call r-aref + %r:13)) + %r:13) + (if start.on.monday (r-block (ref= %r:14 (r-call + (r-call r-aref start (index-in-strlist mday (r-call attr start #0#))) - (r-call ifelse (r-call + (r-call ifelse (r-call > (r-call r-aref start - (index-in-strlist wday (r-call attr start #0#))) + (index-in-strlist wday (r-call attr start #0#))) 0) - 1 (r-call + 1 (r-call - 6)))) - (<- start (r-call r-aref<- start - (index-in-strlist - mday (r-call attr + (<- start (r-call r-aref<- start + (index-in-strlist + mday (r-call attr start #0#)) - %r:14)) - %r:14)) - (<- incr (r-call * 7 86400)))) - (if (r-call + %r:14)) + %r:14)) + (<- incr (r-call * 7 86400)))) + (if (r-call == valid 6) (r-block (r-block (<- start (r-call r-aref<- start - (index-in-strlist mday (r-call attr start + (index-in-strlist mday (r-call attr start #0#)) - 1)) - 1) - (<- incr (r-call * 31 86400)))) - (if (r-call + 1)) + 1) + (<- incr (r-call * 31 86400)))) + (if (r-call == valid 7) (r-block (r-block (<- start (r-call r-aref<- start - (index-in-strlist mon (r-call attr start - #0#)) - 0)) - 0) - (r-block (<- start (r-call r-aref<- start - (index-in-strlist mday (r-call attr start + (index-in-strlist mon (r-call attr start + #0#)) + 0)) + 0) + (r-block (<- start (r-call r-aref<- start + (index-in-strlist mday (r-call attr start #0#)) - 1)) - 1) - (<- incr (r-call * 366 86400)))) - (if (r-call + 1)) + 1) + (<- incr (r-call * 366 86400)))) + (if (r-call == valid 8) (<- incr (r-call * 25 3600))) - (if (r-call + (if (r-call == (r-call length by2) 2) (<- incr (r-call * incr - (r-call as.integer (r-call r-index by2 1))))) - (<- maxx (r-call + (r-call as.integer (r-call r-index by2 1))))) + (<- maxx (r-call max x (*named* na.rm *r-true*))) - (<- breaks + (<- breaks (r-call seq.int start - (r-call + maxx incr) breaks)) - (<- breaks + (r-call + maxx incr) breaks)) + (<- breaks (r-call r-index breaks - (r-call : 1 - (r-call + 1 - (r-call max (r-call which (r-call < breaks maxx)))))))) - (r-call stop "invalid specification of 'breaks'")))) - (<- res (r-call cut (r-call - unclass x) - (r-call unclass + (r-call : 1 + (r-call + 1 + (r-call max (r-call which (r-call < breaks maxx)))))))) + (r-call stop "invalid specification of 'breaks'")))) + (<- res (r-call cut (r-call + unclass x) + (r-call unclass breaks) - (*named* labels + (*named* labels labels) - (*named* right + (*named* right right) - r-dotdotdot)) - (if (r-call is.null labels) - (r-block (ref= %r:15 (r-call + r-dotdotdot)) + (if (r-call is.null labels) + (r-block (ref= %r:15 (r-call as.character (r-call r-index breaks - (r-call - (r-call length breaks))))) - (<- res (r-call - levels<- - res %r:15)) - %r:15)) - res)))) - (<- julian (lambda (x ...) - (let () (r-block (r-call UseMethod "julian"))))) - (<- julian.POSIXt (lambda (x origin ...) - (let ((res ()) - (origin ())) - (r-block (when (missing origin) - (<- origin (r-call - as.POSIXct - "1970-01-01" - (*named* tz + (r-call - (r-call length breaks))))) + (<- res (r-call + levels<- + res %r:15)) + %r:15)) + res)))) + (<- julian (lambda (x ...) + (let () (r-block (r-call UseMethod "julian"))))) + (<- julian.POSIXt (lambda (x origin ...) + (let ((res ()) + (origin ())) + (r-block (when (missing origin) + (<- origin (r-call + as.POSIXct + "1970-01-01" + (*named* tz "GMT")))) - (if (r-call != (r-call length + (if (r-call != (r-call length origin) - 1) - (r-call stop "'origin' must be of length one")) - (<- res (r-call difftime (r-call + 1) + (r-call stop "'origin' must be of length one")) + (<- res (r-call difftime (r-call as.POSIXct x) - origin (*named* + origin (*named* units "days"))) - (r-call structure res - (*named* origin origin)))))) - (<- weekdays (lambda (x abbreviate) - (let () (r-block (r-call UseMethod "weekdays"))))) - (<- weekdays.POSIXt (lambda (x abbreviate) - (let ((abbreviate ())) - (r-block (when (missing abbreviate) - (<- abbreviate - *r-false*)) - (r-call format x - (r-call ifelse - abbreviate - "%a" "%A")))))) - (<- months (lambda (x abbreviate) - (let () (r-block (r-call UseMethod "months"))))) - (<- months.POSIXt (lambda (x abbreviate) - (let ((abbreviate ())) - (r-block (when (missing abbreviate) - (<- abbreviate *r-false*)) - (r-call format x - (r-call ifelse - abbreviate "%b" - "%B")))))) - (<- quarters (lambda (x abbreviate) - (let () (r-block (r-call UseMethod "quarters"))))) - (<- quarters.POSIXt (lambda (x ...) - (let ((x ())) - (r-block (<- x (r-call %/% (r-block + (r-call structure res + (*named* origin origin)))))) + (<- weekdays (lambda (x abbreviate) + (let () (r-block (r-call UseMethod "weekdays"))))) + (<- weekdays.POSIXt (lambda (x abbreviate) + (let ((abbreviate ())) + (r-block (when (missing abbreviate) + (<- abbreviate + *r-false*)) + (r-call format x + (r-call ifelse + abbreviate + "%a" "%A")))))) + (<- months (lambda (x abbreviate) + (let () (r-block (r-call UseMethod "months"))))) + (<- months.POSIXt (lambda (x abbreviate) + (let ((abbreviate ())) + (r-block (when (missing abbreviate) + (<- abbreviate *r-false*)) + (r-call format x + (r-call ifelse + abbreviate "%b" + "%B")))))) + (<- quarters (lambda (x abbreviate) + (let () (r-block (r-call UseMethod "quarters"))))) + (<- quarters.POSIXt (lambda (x ...) + (let ((x ())) + (r-block (<- x (r-call %/% (r-block (ref= %r:0 (r-call as.POSIXlt x)) (r-call r-aref %r:0 - (index-in-strlist mon (r-call attr + (index-in-strlist mon (r-call attr %r:0 #0#)))) - 3)) - (r-call paste "Q" - (r-call + x 1) - (*named* sep "")))))) - (<- trunc.POSIXt (lambda (x units) - (let ((x ()) - (units ())) - (r-block (when (missing units) - (<- units (r-call c "secs" + 3)) + (r-call paste "Q" + (r-call + x 1) + (*named* sep "")))))) + (<- trunc.POSIXt (lambda (x units) + (let ((x ()) + (units ())) + (r-block (when (missing units) + (<- units (r-call c "secs" "mins" "hours" "days"))) - (<- units (r-call match.arg - units)) - (<- x (r-call as.POSIXlt x)) - (if (r-call > (r-call length (r-call + (<- units (r-call match.arg + units)) + (<- x (r-call as.POSIXlt x)) + (if (r-call > (r-call length (r-call r-aref x (index-in-strlist sec (r-call attr x #0#)))) - 0) - (switch units (*named* secs + 0) + (switch units (*named* secs (r-block (r-block (ref= %r:16 (r-call trunc (r-call r-aref x - (index-in-strlist sec (r-call + (index-in-strlist sec (r-call attr x #0#))))) - (<- x (r-call r-aref<- x - (index-in-strlist sec (r-call attr x #0#)) - %r:16)) - %r:16))) - (*named* mins (r-block + (<- x (r-call r-aref<- x + (index-in-strlist sec (r-call attr x #0#)) + %r:16)) + %r:16))) + (*named* mins (r-block (r-block (<- x (r-call r-aref<- x - (index-in-strlist sec (r-call attr x #0#)) 0)) - 0))) - (*named* hours (r-block + (index-in-strlist sec (r-call attr x #0#)) 0)) + 0))) + (*named* hours (r-block (r-block (<- x (r-call r-aref<- x - (index-in-strlist sec (r-call attr x #0#)) 0)) - 0) + (index-in-strlist sec (r-call attr x #0#)) 0)) + 0) (r-block (<- x (r-call r-aref<- x - (index-in-strlist min (r-call attr x #0#)) 0)) - 0))) - (*named* days (r-block + (index-in-strlist min (r-call attr x #0#)) 0)) + 0))) + (*named* days (r-block (r-block (<- x (r-call r-aref<- x - (index-in-strlist sec (r-call attr x #0#)) 0)) - 0) + (index-in-strlist sec (r-call attr x #0#)) 0)) + 0) (r-block (<- x (r-call r-aref<- x - (index-in-strlist min (r-call attr x #0#)) 0)) - 0) + (index-in-strlist min (r-call attr x #0#)) 0)) + 0) (r-block (<- x (r-call r-aref<- x - (index-in-strlist hour (r-call attr x #0#)) 0)) - 0) + (index-in-strlist hour (r-call attr x #0#)) 0)) + 0) (r-block (ref= %r:17 (r-call - 1)) (<- x (r-call r-aref<- x - (index-in-strlist isdst (r-call + (index-in-strlist isdst (r-call attr x #0#)) - %r:17)) - %r:17))))) - x)))) - (<- round.POSIXt (lambda (x units) - (let ((x ()) - (units ())) - (r-block (when (missing units) - (<- units (r-call c "secs" + %r:17)) + %r:17))))) + x)))) + (<- round.POSIXt (lambda (x units) + (let ((x ()) + (units ())) + (r-block (when (missing units) + (<- units (r-call c "secs" "mins" "hours" "days"))) - (if (&& (r-call is.numeric - units) - (r-call == units 0)) - (<- units "secs")) - (<- units (r-call match.arg - units)) - (<- x (r-call as.POSIXct x)) - (<- x (r-call + x - (switch units (*named* + (if (&& (r-call is.numeric + units) + (r-call == units 0)) + (<- units "secs")) + (<- units (r-call match.arg + units)) + (<- x (r-call as.POSIXct x)) + (<- x (r-call + x + (switch units (*named* secs 0.5) (*named* mins 30) (*named* hours 1800) (*named* days 43200)))) - (r-call trunc.POSIXt x - (*named* units units)))))) - (<- "[.POSIXlt" (lambda (x ... drop) - (let ((val ()) - (drop ())) - (r-block (when (missing drop) - (<- drop *r-true*)) - (<- val (r-call lapply x "[" - r-dotdotdot (*named* + (r-call trunc.POSIXt x + (*named* units units)))))) + (<- "[.POSIXlt" (lambda (x ... drop) + (let ((val ()) + (drop ())) + (r-block (when (missing drop) + (<- drop *r-true*)) + (<- val (r-call lapply x "[" + r-dotdotdot (*named* drop drop))) - (r-block (ref= %r:18 (r-call + (r-block (ref= %r:18 (r-call attributes x)) - (<- val (r-call - attributes<- - val %r:18)) - %r:18) - val)))) - (<- "[<-.POSIXlt" (lambda (x i value) - (let ((x ()) - (cl ()) - (value ())) - (r-block (if (r-call ! (r-call - as.logical (r-call + (<- val (r-call + attributes<- + val %r:18)) + %r:18) + val)))) + (<- "[<-.POSIXlt" (lambda (x i value) + (let ((x ()) + (cl ()) + (value ())) + (r-block (if (r-call ! (r-call + as.logical (r-call length value))) - (return x)) - (<- value (r-call as.POSIXlt - value)) - (<- cl (r-call oldClass x)) - (r-block (ref= %r:19 (r-block + (return x)) + (<- value (r-call as.POSIXlt + value)) + (<- cl (r-call oldClass x)) + (r-block (ref= %r:19 (r-block (<- value (r-call class<- value - ())) + ())) ())) - (<- x (r-call class<- + (<- x (r-call class<- x %r:19)) - %r:19) - (for n (r-call names x) - (r-block (ref= %r:20 (r-call + %r:19) + (for n (r-call names x) + (r-block (ref= %r:20 (r-call r-aref value n)) - (r-block (ref= + (r-block (ref= %r:21 (r-call r-index<- (r-call r-aref x n) i %r:20)) (<- x (r-call r-aref<- x n %r:21)) %r:21) - %r:20)) - (r-block (<- x (r-call class<- + %r:20)) + (r-block (<- x (r-call class<- x cl)) - cl) - x)))) - (<- as.data.frame.POSIXlt (lambda (x row.names optional ...) - (let ((value ()) - (optional ()) - (row.names ())) - (r-block (when (missing - row.names) - (<- row.names ())) - (when (missing - optional) - (<- optional - *r-false*)) - (<- value (r-call - as.data.frame.POSIXct - (r-call + cl) + x)))) + (<- as.data.frame.POSIXlt (lambda (x row.names optional ...) + (let ((value ()) + (optional ()) + (row.names ())) + (r-block (when (missing + row.names) + (<- row.names ())) + (when (missing + optional) + (<- optional + *r-false*)) + (<- value (r-call + as.data.frame.POSIXct + (r-call as.POSIXct x) - row.names - optional - r-dotdotdot)) - (if (r-call ! optional) - (r-block (ref= + row.names + optional + r-dotdotdot)) + (if (r-call ! optional) + (r-block (ref= %r:22 (r-call r-aref (r-call deparse (substitute x)) 1)) (<- value (r-call names<- value %r:22)) %r:22)) - value)))) - (<- rep.POSIXct (lambda (x ...) - (let ((y ())) - (r-block (<- y (r-call NextMethod)) - (r-call structure y - (*named* class (r-call + value)))) + (<- rep.POSIXct (lambda (x ...) + (let ((y ())) + (r-block (<- y (r-call NextMethod)) + (r-call structure y + (*named* class (r-call c "POSIXt" "POSIXct")) - (*named* tzone (r-call + (*named* tzone (r-call attr x "tzone"))))))) - (<- rep.POSIXlt (lambda (x ...) - (let ((y ())) - (r-block (<- y (r-call lapply x rep - r-dotdotdot)) - (r-block (ref= %r:23 (r-call + (<- rep.POSIXlt (lambda (x ...) + (let ((y ())) + (r-block (<- y (r-call lapply x rep + r-dotdotdot)) + (r-block (ref= %r:23 (r-call attributes x)) - (<- y (r-call - attributes<- y - %r:23)) - %r:23) - y)))) - (<- diff.POSIXt (lambda (x lag differences ...) - (let ((i1 ()) - (xlen ()) - (r ()) - (ismat ()) - (differences ()) - (lag ())) - (r-block (when (missing lag) - (<- lag 1)) - (when (missing differences) - (<- differences 1)) - (<- ismat (r-call is.matrix x)) - (<- r (if (r-call inherits x "POSIXlt") - (r-call as.POSIXct x) - x)) - (<- xlen (if ismat (r-call - r-index (r-call + (<- y (r-call + attributes<- y + %r:23)) + %r:23) + y)))) + (<- diff.POSIXt (lambda (x lag differences ...) + (let ((i1 ()) + (xlen ()) + (r ()) + (ismat ()) + (differences ()) + (lag ())) + (r-block (when (missing lag) + (<- lag 1)) + (when (missing differences) + (<- differences 1)) + (<- ismat (r-call is.matrix x)) + (<- r (if (r-call inherits x "POSIXlt") + (r-call as.POSIXct x) + x)) + (<- xlen (if ismat (r-call + r-index (r-call dim x) - 1) - (r-call length r))) - (if (|\|\|| (r-call > (r-call + 1) + (r-call length r))) + (if (|\|\|| (r-call > (r-call length lag) - 1) - (r-call > (r-call + 1) + (r-call > (r-call length differences) - 1) - (r-call < lag 1) - (r-call < - differences - 1)) - (r-call stop "'lag' and 'differences' must be integers >= 1")) - (if (r-call >= (r-call * lag + 1) + (r-call < lag 1) + (r-call < + differences + 1)) + (r-call stop "'lag' and 'differences' must be integers >= 1")) + (if (r-call >= (r-call * lag differences) - xlen) - (return (r-call structure (r-call + xlen) + (return (r-call structure (r-call numeric 0) - (*named* - class "difftime") - (*named* - units "secs")))) - (<- i1 (r-call : (r-call - 1) - (r-call - lag))) - (if ismat (for i (r-call : 1 + (*named* + class "difftime") + (*named* + units "secs")))) + (<- i1 (r-call : (r-call - 1) + (r-call - lag))) + (if ismat (for i (r-call : 1 differences) - (<- r (r-call - (r-call + (<- r (r-call - (r-call r-index r i1 *r-missing* (*named* drop *r-false*)) (r-call r-index r - (r-call : (r-call - (r-call nrow r)) - (r-call - (r-call + (r-call - (r-call nrow r) lag) 1))) - *r-missing* (*named* drop *r-false*))))) - (for i (r-call : 1 - differences) - (<- r (r-call - (r-call + (r-call : (r-call - (r-call nrow r)) + (r-call - (r-call + (r-call - (r-call nrow r) lag) 1))) + *r-missing* (*named* drop *r-false*))))) + (for i (r-call : 1 + differences) + (<- r (r-call - (r-call r-index r i1) - (r-call - r-index r - (r-call : + (r-call + r-index r + (r-call : (r-call - (r-call length r)) (r-call - (r-call + (r-call - (r-call length r) - lag) - 1)))))))) - r)))) - (<- duplicated.POSIXlt (lambda (x incomparables ...) - (let ((x ()) - (incomparables ())) - (r-block (when (missing - incomparables) - (<- incomparables - *r-false*)) - (<- x (r-call as.POSIXct - x)) - (r-call NextMethod "duplicated" - x))))) - (<- unique.POSIXlt (lambda (x incomparables ...) - (let ((incomparables ())) - (r-block (when (missing incomparables) - (<- incomparables - *r-false*)) - (r-call r-index x - (r-call ! (r-call + lag) + 1)))))))) + r)))) + (<- duplicated.POSIXlt (lambda (x incomparables ...) + (let ((x ()) + (incomparables ())) + (r-block (when (missing + incomparables) + (<- incomparables + *r-false*)) + (<- x (r-call as.POSIXct + x)) + (r-call NextMethod "duplicated" + x))))) + (<- unique.POSIXlt (lambda (x incomparables ...) + (let ((incomparables ())) + (r-block (when (missing incomparables) + (<- incomparables + *r-false*)) + (r-call r-index x + (r-call ! (r-call duplicated x incomparables r-dotdotdot))))))) - (<- sort.POSIXlt (lambda (x decreasing na.last ...) - (let ((na.last ()) - (decreasing ())) - (r-block (when (missing decreasing) - (<- decreasing *r-false*)) - (when (missing na.last) - (<- na.last NA)) - (r-call r-index x - (r-call order (r-call + (<- sort.POSIXlt (lambda (x decreasing na.last ...) + (let ((na.last ()) + (decreasing ())) + (r-block (when (missing decreasing) + (<- decreasing *r-false*)) + (when (missing na.last) + (<- na.last NA)) + (r-call r-index x + (r-call order (r-call as.POSIXct x) - (*named* - na.last - na.last) - (*named* - decreasing - decreasing)))))))) + (*named* + na.last + na.last) + (*named* + decreasing + decreasing)))))))) diff --git a/scheme-tests/ast/rpasses.scm b/scheme-tests/ast/rpasses.scm index 1822fca..353eeb1 100644 --- a/scheme-tests/ast/rpasses.scm +++ b/scheme-tests/ast/rpasses.scm @@ -21,21 +21,23 @@ (let ((ctr 0)) (set! r-gensym (lambda () - (prog1 (symbol (string "%r:" ctr)) - (set! ctr (+ ctr 1)))))) + (prog1 (symbol (string "%r:" ctr)) + (set! ctr (+ ctr 1)))))) (define (dollarsign-transform e) (pattern-expand - (pattern-lambda ($ lhs name) - (let* ((g (if (not (pair? lhs)) lhs (r-gensym))) - (n (if (symbol? name) - name ;(symbol->string name) - name)) - (expr `(r-call - r-aref ,g (index-in-strlist ,n (r-call attr ,g "names"))))) - (if (not (pair? lhs)) - expr - `(r-block (ref= ,g ,lhs) ,expr)))) + (pattern-lambda + ($ lhs name) + (let* ((g (if (not (pair? lhs)) lhs (r-gensym))) + (n (if (symbol? name) + name ;(symbol->string name) + name)) + (expr `(r-call + r-aref ,g + (index-in-strlist ,n (r-call attr ,g "names"))))) + (if (not (pair? lhs)) + expr + `(r-block (ref= ,g ,lhs) ,expr)))) e)) ; lower r expressions of the form f(lhs,...) <- rhs @@ -47,10 +49,11 @@ (pattern-expand (pattern-lambda (-$ (<- (r-call f lhs ...) rhs) (<<- (r-call f lhs ...) rhs)) - (let ((g (if (pair? rhs) (r-gensym) rhs)) + (let ((g (if (pair? rhs) (r-gensym) rhs)) (op (car __))) - `(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ()) - (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g)) + `(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ()) + (,op ,lhs (r-call ,(symconcat f '<-) + ,@(cddr (cadr __)) ,g)) ,g))) e)) @@ -60,35 +63,36 @@ ; added to its body (define (gen-default-inits arglist) (map (lambda (arg) - (let ((name (cadr arg)) - (default (caddr arg))) - `(when (missing ,name) + (let ((name (cadr arg)) + (default (caddr arg))) + `(when (missing ,name) (<- ,name ,default)))) - (filter (lambda (arg) (not (eq (caddr arg) missing-arg-tag))) arglist))) + (filter (lambda (arg) (not (eq (caddr arg) missing-arg-tag))) + arglist))) ; convert r function expressions to lambda (define (normalize-r-functions e) (maptree-post (lambda (n) - (if (and (pair? n) (eq (car n) 'function)) - `(lambda ,(func-argnames n) - (r-block ,@(gen-default-inits (cadr n)) - ,@(if (and (pair? (caddr n)) - (eq (car (caddr n)) 'r-block)) - (cdr (caddr n)) + (if (and (pair? n) (eq (car n) 'function)) + `(lambda ,(func-argnames n) + (r-block ,@(gen-default-inits (cadr n)) + ,@(if (and (pair? (caddr n)) + (eq (car (caddr n)) 'r-block)) + (cdr (caddr n)) (list (caddr n))))) n)) - e)) + e)) (define (find-assigned-vars n) (let ((vars ())) (maptree-pre (lambda (s) - (if (not (pair? s)) s + (if (not (pair? s)) s (cond ((eq (car s) 'lambda) ()) ((eq (car s) '<-) (set! vars (list-adjoin (cadr s) vars)) (cddr s)) (#t s)))) - n) + n) vars)) ; introduce let based on assignment statements diff --git a/scheme-tests/color.scm b/scheme-tests/color.scm index 1f3fd2d..fbfd121 100644 --- a/scheme-tests/color.scm +++ b/scheme-tests/color.scm @@ -1,6 +1,6 @@ ; -*- scheme -*- -; dictionaries ---------------------------------------------------------------- +; dictionaries --------------------------------------------------------------- (define (dict-new) ()) (define (dict-extend dl key value) @@ -15,7 +15,7 @@ (define (dict-keys dl) (map car dl)) -; graphs ---------------------------------------------------------------------- +; graphs --------------------------------------------------------------------- (define (graph-empty) (dict-new)) (define (graph-connect g n1 n2) @@ -39,7 +39,7 @@ (caar edge-list) (cdar edge-list)))) -; graph coloring -------------------------------------------------------------- +; graph coloring ------------------------------------------------------------- (define (node-colorable? g coloring node-to-color color-of-node) (not (member color-of-node @@ -52,7 +52,7 @@ (define (try-each f lst) (if (null? lst) #f (let ((ret (f (car lst)))) - (if ret ret (try-each f (cdr lst)))))) + (if ret ret (try-each f (cdr lst)))))) (define (color-node g coloring colors uncolored-nodes color) (cond @@ -72,7 +72,7 @@ (define (color-pairs pairs colors) (color-graph (graph-from-edges pairs) colors)) -; queens ---------------------------------------------------------------------- +; queens --------------------------------------------------------------------- (define (can-attack x y) (let ((x1 (mod x 5)) (y1 (truncate (/ x 5))) diff --git a/scheme-tests/equal.scm b/scheme-tests/equal.scm index ce6b30f..35d7c0d 100644 --- a/scheme-tests/equal.scm +++ b/scheme-tests/equal.scm @@ -7,14 +7,14 @@ ; nontermination, otherwise #t or #f for the correct answer. (define (bounded-equal a b N) (cond ((<= N 0) 0) - ((and (pair? a) (pair? b)) - (let ((as - (bounded-equal (car a) (car b) (- N 1)))) - (if (number? as) - 0 - (and as - (bounded-equal (cdr a) (cdr b) (- N 1)))))) - (else (eq? a b)))) + ((and (pair? a) (pair? b)) + (let ((as + (bounded-equal (car a) (car b) (- N 1)))) + (if (number? as) + 0 + (and as + (bounded-equal (cdr a) (cdr b) (- N 1)))))) + (else (eq? a b)))) ; union-find algorithm @@ -23,8 +23,8 @@ (define (class table key) (let ((c (hashtable-ref table key #f))) (if (or (not c) (eq? c key)) - c - (class table c)))) + c + (class table c)))) ; move a and b to the same equivalence class, given c and cb ; as the current values of (class table a) and (class table b) @@ -34,7 +34,7 @@ (define (union! table a b c cb) (let ((ca (if c c a))) (if cb - (hashtable-set! table cb ca)) + (hashtable-set! table cb ca)) (hashtable-set! table a ca) (hashtable-set! table b ca))) @@ -43,26 +43,26 @@ ; set them equal and move on. (define (cyc-equal a b table) (cond ((eq? a b) #t) - ((not (and (pair? a) (pair? b))) (eq? a b)) - (else - (let ((aa (car a)) (da (cdr a)) - (ab (car b)) (db (cdr b))) - (cond ((or (not (eq? (atom? aa) (atom? ab))) - (not (eq? (atom? da) (atom? db)))) #f) - ((and (atom? aa) - (not (eq? aa ab))) #f) - ((and (atom? da) - (not (eq? da db))) #f) - (else - (let ((ca (class table a)) - (cb (class table b))) - (if (and ca cb (eq? ca cb)) - #t - (begin (union! table a b ca cb) - (and (cyc-equal aa ab table) - (cyc-equal da db table))))))))))) + ((not (and (pair? a) (pair? b))) (eq? a b)) + (else + (let ((aa (car a)) (da (cdr a)) + (ab (car b)) (db (cdr b))) + (cond ((or (not (eq? (atom? aa) (atom? ab))) + (not (eq? (atom? da) (atom? db)))) #f) + ((and (atom? aa) + (not (eq? aa ab))) #f) + ((and (atom? da) + (not (eq? da db))) #f) + (else + (let ((ca (class table a)) + (cb (class table b))) + (if (and ca cb (eq? ca cb)) + #t + (begin (union! table a b ca cb) + (and (cyc-equal aa ab table) + (cyc-equal da db table))))))))))) (define (equal a b) (let ((guess (bounded-equal a b 2048))) (if (boolean? guess) guess - (cyc-equal a b (make-eq-hashtable))))) + (cyc-equal a b (make-eq-hashtable))))) diff --git a/scheme-tests/perf.scm b/scheme-tests/perf.scm index ea40e90..ef81974 100644 --- a/scheme-tests/perf.scm +++ b/scheme-tests/perf.scm @@ -19,10 +19,10 @@ (cond ((null? lsts) ()) ((null? (cdr lsts)) (car lsts)) (else (letrec ((append2 (lambda (l d) - (if (null? l) d - (cons (car l) - (append2 (cdr l) d)))))) - (append2 (car lsts) (apply my-append (cdr lsts))))))) + (if (null? l) d + (cons (car l) + (append2 (cdr l) d)))))) + (append2 (car lsts) (apply my-append (cdr lsts))))))) (princ "append: ") (set! L (map-int (lambda (x) (map-int identity 20)) 20)) diff --git a/scheme-tests/printcases.scm b/scheme-tests/printcases.scm index 9e8caa4..824fe67 100644 --- a/scheme-tests/printcases.scm +++ b/scheme-tests/printcases.scm @@ -14,11 +14,14 @@ bq-process (list->vector (map-int (lambda (x) `(a b c d e)) 90)) -'((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y)) +'((lambda (x y) (if (< x y) x y)) + (a b c) (d e f) 2 3 (r t y)) -'((lambda (x y) (if (< x y) x yffffffffffffffffffff)) (a b c) (d e f) 2 3 (r t y)) +'((lambda (x y) (if (< x y) x yffffffffffffffffffff)) + (a b c) (d e f) 2 3 (r t y)) -'((lambda (x y) (if (< x y) x y)) (a b c) (d (e zz zzz) f) 2 3 (r t y)) +'((lambda (x y) (if (< x y) x y)) + (a b c) (d (e zz zzz) f) 2 3 (r t y)) '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e) (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d) diff --git a/scheme-tests/tcolor.scm b/scheme-tests/tcolor.scm index 3b9b312..f6e5c64 100644 --- a/scheme-tests/tcolor.scm +++ b/scheme-tests/tcolor.scm @@ -10,7 +10,7 @@ (dotimes (n 99) (color-pairs Q '(a b c d e)))) (time (ct)) (assert (equal? C - '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e) - (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d) - (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e) - (3 . d) (2 . c) (0 . b) (1 . a)))) + '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) + (21 . e) (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) + (24 . c) (20 . d) (18 . e) (15 . a) (12 . a) (10 . e) + (6 . d) (5 . c) (4 . e) (3 . d) (2 . c) (0 . b) (1 . a)))) diff --git a/scheme-tests/test.scm b/scheme-tests/test.scm index 8d5d15b..eb3a2ad 100644 --- a/scheme-tests/test.scm +++ b/scheme-tests/test.scm @@ -19,10 +19,10 @@ (cond ((null? lsts) ()) ((null? (cdr lsts)) (car lsts)) (#t ((label append2 (lambda (l d) - (if (null? l) d - (cons (car l) - (append2 (cdr l) d))))) - (car lsts) (append-h (cdr lsts))))))) + (if (null? l) d + (cons (car l) + (append2 (cdr l) d))))) + (car lsts) (append-h (cdr lsts))))))) lsts)) ;(princ 'Hello '| | 'world! "\n") @@ -49,13 +49,13 @@ (if (<= n 0) () (let ((first (cons (f 0) ()))) - ((label map-int- - (lambda (acc i n) - (if (= i n) - first - (begin (set-cdr! acc (cons (f i) ())) - (map-int- (cdr acc) (+ i 1) n))))) - first 1 n)))) + ((label map-int- + (lambda (acc i n) + (if (= i n) + first + (begin (set-cdr! acc (cons (f i) ())) + (map-int- (cdr acc) (+ i 1) n))))) + first 1 n)))) |# (define-macro (labl name fn) @@ -91,7 +91,7 @@ ((label mapl- (lambda (lsts) (if (null? (car lsts)) () - (begin (apply f lsts) (mapl- (map cdr lsts)))))) + (begin (apply f lsts) (mapl- (map cdr lsts)))))) lsts)) ; test to see if a symbol begins with : @@ -102,7 +102,7 @@ (define (swapad c) (if (atom? c) c (set-cdr! c (K (swapad (car c)) - (set-car! c (swapad (cdr c))))))) + (set-car! c (swapad (cdr c))))))) (define (without x l) (filter (lambda (e) (not (eq e x))) l)) @@ -120,14 +120,14 @@ ;[` _ ,_ |- | . _ 2 ;| (/_||||_()|_|_\|) -; | +; | (define-macro (while- test . forms) `((label -loop- (lambda () (if ,test (begin ,@forms (-loop-)) - ()))))) + ()))))) ; this would be a cool use of thunking to handle 'finally' clauses, but ; this code doesn't work in the case where the user manually re-raises @@ -183,22 +183,22 @@ (let ((acc (gensym))) `(let ((,acc (list ()))) (cdr - (prog1 ,acc - (while ,cnd - (begin (set! ,acc - (cdr (set-cdr! ,acc (cons ,what ())))) - ,@body))))))) + (prog1 ,acc + (while ,cnd + (begin (set! ,acc + (cdr (set-cdr! ,acc (cons ,what ())))) + ,@body))))))) (define-macro (accumulate-for var lo hi what . body) (let ((acc (gensym))) `(let ((,acc (list ()))) (cdr - (prog1 ,acc - (for ,lo ,hi - (lambda (,var) - (begin (set! ,acc - (cdr (set-cdr! ,acc (cons ,what ())))) - ,@body)))))))) + (prog1 ,acc + (for ,lo ,hi + (lambda (,var) + (begin (set! ,acc + (cdr (set-cdr! ,acc (cons ,what ())))) + ,@body)))))))) (define (map-indexed f lst) (if (atom? lst) lst @@ -211,84 +211,84 @@ (define (sub h n offs lst) (let ((i (string.find h n offs))) (if i - (sub h n (string.inc h i) (cons i lst)) - (reverse! lst)))) + (sub h n (string.inc h i) (cons i lst)) + (reverse! lst)))) (sub haystack needle (if (null? offs) 0 (car offs)) ())) (let ((*profiles* (table))) (set! profile - (lambda (s) - (let ((f (top-level-value s))) - (put! *profiles* s (cons 0 0)) - (set-top-level-value! s - (lambda args - (define tt (get *profiles* s)) - (define count (car tt)) - (define time (cdr tt)) - (define t0 (time.now)) - (define v (apply f args)) - (set-cdr! tt (+ time (- (time.now) t0))) - (set-car! tt (+ count 1)) - v))))) + (lambda (s) + (let ((f (top-level-value s))) + (put! *profiles* s (cons 0 0)) + (set-top-level-value! s + (lambda args + (define tt (get *profiles* s)) + (define count (car tt)) + (define time (cdr tt)) + (define t0 (time.now)) + (define v (apply f args)) + (set-cdr! tt (+ time (- (time.now) t0))) + (set-car! tt (+ count 1)) + v))))) (set! show-profiles - (lambda () - (define pr (filter (lambda (x) (> (cadr x) 0)) - (table.pairs *profiles*))) - (define width (+ 4 - (apply max - (map (lambda (x) - (length (string x))) - (cons 'Function - (map car pr)))))) - (princ (string.rpad "Function" width #\ ) - "#Calls Time (seconds)") - (newline) - (princ (string.rpad "--------" width #\ ) - "------ --------------") - (newline) - (for-each - (lambda (p) - (princ (string.rpad (string (caddr p)) width #\ ) - (string.rpad (string (cadr p)) 11 #\ ) - (car p)) - (newline)) - (simple-sort (map (lambda (l) (reverse (to-proper l))) - pr))))) + (lambda () + (define pr (filter (lambda (x) (> (cadr x) 0)) + (table.pairs *profiles*))) + (define width (+ 4 + (apply max + (map (lambda (x) + (length (string x))) + (cons 'Function + (map car pr)))))) + (princ (string.rpad "Function" width #\ ) + "#Calls Time (seconds)") + (newline) + (princ (string.rpad "--------" width #\ ) + "------ --------------") + (newline) + (for-each + (lambda (p) + (princ (string.rpad (string (caddr p)) width #\ ) + (string.rpad (string (cadr p)) 11 #\ ) + (car p)) + (newline)) + (simple-sort (map (lambda (l) (reverse (to-proper l))) + pr))))) (set! clear-profiles - (lambda () - (for-each (lambda (k) - (put! *profiles* k (cons 0 0))) - (table.keys *profiles*))))) + (lambda () + (for-each (lambda (k) + (put! *profiles* k (cons 0 0))) + (table.keys *profiles*))))) #;(for-each profile - '(emit encode-byte-code const-to-idx-vec - index-of lookup-sym in-env? any every - compile-sym compile-if compile-begin - compile-arglist expand builtin->instruction - compile-app separate nconc get-defined-vars - compile-in compile compile-f delete-duplicates - map length> length= count filter append - lastcdr to-proper reverse reverse! list->vector - table.foreach list-head list-tail assq memq assoc member - assv memv nreconc bq-process)) + '(emit encode-byte-code const-to-idx-vec + index-of lookup-sym in-env? any every + compile-sym compile-if compile-begin + compile-arglist expand builtin->instruction + compile-app separate nconc get-defined-vars + compile-in compile compile-f delete-duplicates + map length> length= count filter append + lastcdr to-proper reverse reverse! list->vector + table.foreach list-head list-tail assq memq assoc member + assv memv nreconc bq-process)) (define (filt1 pred lst) (define (filt1- pred lst accum) (if (null? lst) accum - (if (pred (car lst)) - (filt1- pred (cdr lst) (cons (car lst) accum)) - (filt1- pred (cdr lst) accum)))) + (if (pred (car lst)) + (filt1- pred (cdr lst) (cons (car lst) accum)) + (filt1- pred (cdr lst) accum)))) (filt1- pred lst ())) (define (filto pred lst (accum ())) (if (atom? lst) accum (if (pred (car lst)) - (filto pred (cdr lst) (cons (car lst) accum)) - (filto pred (cdr lst) accum)))) + (filto pred (cdr lst) (cons (car lst) accum)) + (filto pred (cdr lst) accum)))) ; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d)) (define (pairwise? pred . args) (or (null? args) (let f ((a (car args)) (d (cdr args))) - (or (null? d) - (and (pred a (car d)) (f (car d) (cdr d))))))) + (or (null? d) + (and (pred a (car d)) (f (car d) (cdr d))))))) diff --git a/scheme-tests/torture.scm b/scheme-tests/torture.scm index 1231477..c3da00a 100644 --- a/scheme-tests/torture.scm +++ b/scheme-tests/torture.scm @@ -19,6 +19,6 @@ (define (f x) (begin (write x) - (newline) - (f (+ x 1)) - 0)) + (newline) + (f (+ x 1)) + 0)) diff --git a/scheme-tests/unittest.scm b/scheme-tests/unittest.scm index 1ebe4f9..00b5430 100644 --- a/scheme-tests/unittest.scm +++ b/scheme-tests/unittest.scm @@ -1,11 +1,14 @@ ; -*- scheme -*- (define-macro (assert-fail expr . what) `(assert (trycatch (begin ,expr #f) - (lambda (e) ,(if (null? what) #t - `(eq? (car e) ',(car what))))))) + (lambda (e) ,(if (null? what) #t + `(eq? (car e) ',(car what))))))) (define (every-int n) - (list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n) + (list (fixnum n) + (int8 n) (uint8 n) + (int16 n) (uint16 n) + (int32 n) (uint32 n) (int64 n) (uint64 n))) (define (every-sint n) @@ -14,7 +17,7 @@ (define (each f l) (if (atom? l) () (begin (f (car l)) - (each f (cdr l))))) + (each f (cdr l))))) (define (each^2 f l m) (each (lambda (o) (each (lambda (p) (f o p)) m)) l)) @@ -71,9 +74,9 @@ (assert (not (equal? #int64(0x8000000000000000) #uint64(0x8000000000000000)))) (assert (equal? (+ #int64(0x4000000000000000) #int64(0x4000000000000000)) - #uint64(0x8000000000000000))) + #uint64(0x8000000000000000))) (assert (equal? (* 2 #int64(0x4000000000000000)) - #uint64(0x8000000000000000))) + #uint64(0x8000000000000000))) (assert (equal? (uint64 (double -123)) #uint64(0xffffffffffffff85))) @@ -128,9 +131,9 @@ (assert (= (apply + (iota 100000)) 4999950000)) (define ones (map (lambda (x) 1) (iota 80000))) (assert (= (eval `(if (< 2 1) - (+ ,@ones) - (+ ,@(cdr ones)))) - 79999)) + (+ ,@ones) + (+ ,@(cdr ones)))) + 79999)) (define MAX_ARGS 255) @@ -142,10 +145,10 @@ (define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 100)))) (define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42) - ,(car (last-pair as))))) + ,(car (last-pair as))))) (assert (equal? (apply ff (iota (+ MAX_ARGS 100))) 42)) (define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42) - (lambda () ,(car (last-pair as)))))) + (lambda () ,(car (last-pair as)))))) (assert (equal? ((apply ff (iota (+ MAX_ARGS 100)))) 42)) (define as (map-int (lambda (x) (gensym)) 1000)) @@ -173,9 +176,9 @@ (assert (not (keyword? 'kw))) (assert (not (keyword? ':))) (assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 1 0 8 4 5) - '(1 0 0 (8 4 5)))) + '(1 0 0 (8 4 5)))) (assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 0 b: 3 1) - '(0 2 3 (1)))) + '(0 2 3 (1)))) (define (keys4 (a: 8) (b: 3) (c: 7) (d: 6)) (list a b c d)) (assert (equal? (keys4 a: 10) '(10 3 7 6))) (assert (equal? (keys4 b: 10) '(8 10 7 6))) @@ -214,75 +217,75 @@ (load "color.scm") (assert (equal? (color-pairs (generate-5x5-pairs) '(a b c d e)) - '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e) - (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d) - (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e) - (3 . d) (2 . c) (0 . b) (1 . a)))) + '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) + (21 . e) (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) + (24 . c) (20 . d) (18 . e) (15 . a) (12 . a) (10 . e) + (6 . d) (5 . c) (4 . e) (3 . d) (2 . c) (0 . b) (1 . a)))) ; hashing strange things (assert (equal? - (hash '#0=(1 1 #0# . #0#)) - (hash '#1=(1 1 #1# 1 1 #1# . #1#)))) + (hash '#0=(1 1 #0# . #0#)) + (hash '#1=(1 1 #1# 1 1 #1# . #1#)))) (assert (not (equal? - (hash '#0=(1 1 #0# . #0#)) - (hash '#1=(1 2 #1# 1 1 #1# . #1#))))) + (hash '#0=(1 1 #0# . #0#)) + (hash '#1=(1 2 #1# 1 1 #1# . #1#))))) (assert (equal? - (hash '#0=((1 . #0#) . #0#)) - (hash '#1=((1 . #1#) (1 . #1#) . #1#)))) + (hash '#0=((1 . #0#) . #0#)) + (hash '#1=((1 . #1#) (1 . #1#) . #1#)))) (assert (not (equal? - (hash '#0=((1 . #0#) . #0#)) - (hash '#1=((2 . #1#) (1 . #1#) . #1#))))) + (hash '#0=((1 . #0#) . #0#)) + (hash '#1=((2 . #1#) (1 . #1#) . #1#))))) (assert (not (equal? - (hash '#0=((1 . #0#) . #0#)) - (hash '#1=((1 . #1#) (2 . #1#) . #1#))))) + (hash '#0=((1 . #0#) . #0#)) + (hash '#1=((1 . #1#) (2 . #1#) . #1#))))) (assert (equal? - (hash '(#0=(#0#) 0)) - (hash '(#1=(((((#1#))))) 0)))) + (hash '(#0=(#0#) 0)) + (hash '(#1=(((((#1#))))) 0)))) (assert (not (equal? - (hash '(#0=(#0#) 0)) - (hash '(#1=(((((#1#))))) 1))))) + (hash '(#0=(#0#) 0)) + (hash '(#1=(((((#1#))))) 1))))) (assert (equal? - (hash #0=[1 [2 [#0#]] 3]) - (hash #1=[1 [2 [[1 [2 [#1#]] 3]]] 3]))) + (hash #0=[1 [2 [#0#]] 3]) + (hash #1=[1 [2 [[1 [2 [#1#]] 3]]] 3]))) (assert (not (equal? - (hash #0=[1 [2 [#0#]] 3]) - (hash #1=[1 [2 [[5 [2 [#1#]] 3]]] 3])))) + (hash #0=[1 [2 [#0#]] 3]) + (hash #1=[1 [2 [[5 [2 [#1#]] 3]]] 3])))) (assert (equal? - (hash #0=[1 #0# [2 [#0#]] 3]) - (hash #1=[1 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3]))) + (hash #0=[1 #0# [2 [#0#]] 3]) + (hash #1=[1 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3]))) (assert (not (equal? - (hash #0=[1 #0# [2 [#0#]] 3]) - (hash #1=[6 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3])))) + (hash #0=[1 #0# [2 [#0#]] 3]) + (hash #1=[6 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3])))) (assert (equal? - (hash [1 [2 [[1 1 [2 [1]] 3]]] 3]) - (hash [1 [2 [[1 1 [2 [1]] 3]]] 3]))) + (hash [1 [2 [[1 1 [2 [1]] 3]]] 3]) + (hash [1 [2 [[1 1 [2 [1]] 3]]] 3]))) (assert (not (equal? - (hash [6 1 [2 [[3 1 [2 [1]] 3]]] 3]) - (hash [6 1 [2 [[1 1 [2 [1]] 3]]] 3])))) + (hash [6 1 [2 [[3 1 [2 [1]] 3]]] 3]) + (hash [6 1 [2 [[1 1 [2 [1]] 3]]] 3])))) (assert (equal? (hash '#0=(1 . #0#)) - (hash '#1=(1 1 . #1#)))) + (hash '#1=(1 1 . #1#)))) (assert (not (equal? (hash '#0=(1 1 . #0#)) - (hash '#1=(1 #0# . #1#))))) + (hash '#1=(1 #0# . #1#))))) (assert (not (equal? (hash (iota 10)) - (hash (iota 20))))) + (hash (iota 20))))) (assert (not (equal? (hash (iota 41)) - (hash (iota 42))))) + (hash (iota 42))))) (if (top-level-bound? 'time.fromstring) (assert (let ((ts (time.string (time.now)))) diff --git a/scheme-tests/wt.scm b/scheme-tests/wt.scm index a0b8888..6f6bcd2 100644 --- a/scheme-tests/wt.scm +++ b/scheme-tests/wt.scm @@ -14,7 +14,7 @@ (if (< i 10000000) (begin (set! i (+ i 1)) (loop)) - ())))) + ())))) (loop))) #| diff --git a/scripts/build.sh b/scripts/build.sh index 1e37012..7b7036a 100755 --- a/scripts/build.sh +++ b/scripts/build.sh @@ -1,7 +1,8 @@ #!/bin/sh set -eu CC="${CC:-clang}" -CFLAGS="-O2 -falign-functions -Wall -Wno-strict-aliasing -I ../c -D NDEBUG -D USE_COMPUTED_GOTO" +CFLAGS="-O2 -falign-functions -Wall -Wno-strict-aliasing" +CFLAGS="$CFLAGS -I ../c -D NDEBUG -D USE_COMPUTED_GOTO" LFLAGS="-lm" builddir="build-$(uname | tr A-Z- a-z_)-$(uname -m | tr A-Z- a-z_)" cd "$(dirname "$0")"/..